Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1860to1864
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Sheet nach Abfrage erstellen + befüllen

Sheet nach Abfrage erstellen + befüllen
04.01.2022 09:12:29
Björn
Guten Morgen und gesundes Neues Jahr,
Wir planen für einen Wettbewerb dieses Jahr die Kandidatenbewertung etwas komfortabler zu Gestalten in dem wir einige Abläufe automatisieren.
Bisheriges Vorgehen:
Per Dropmenü wird Kandidat ausgewählt und einige Sachen werden Automatisch ausgefüllt (Altersklasse, Gewicht, etc)
Die Restlichen Felder werden per Hand befüllt
Ab hier soll automatisiert werden
Die Tabelle wurde als ganzes in ein neues Sheet kopiert und das Sheet nach dem Kandidaten benannt werden und anschließend wird das Blatt gesperrt
Die Ergebnisse wurden in eine Gesamttabelle eingetragen, in der Beispieldatei Tabelle 2
Nach dem alle Kandidaten, ca. 30, Bewertet wurden, wurde per Handsortiert
Die Sortierung und Sperrung ist erstmal ein Bonus
Hier mein Skript Versuch

Sub test()
Dim lngZiel As Long
Dim Kandidat As String
Dim BoVorhanden As Boolean
Dim WsTabelle As Worksheet
'Skript soll nur die Werte aus Bereich Tabelle1 B2:B4 in Tabelle2 die erste freie Spalte kopieren
'und nur die Werte aus Tabelle 1 A2:B4 in ein neues Tabellenblatt mit Namen aus Tabelle1 A2 kopieren
'im Falle eines schon vorhandenen Tabellenblatts soll eine Abfrage zum Überschreiben erscheinen
For Each WsTabelle In Worksheets 'Abfrage Start ob Kandidat schon eingetragen wurde
If WsTabelle.Name = Sheets("Tabelle1").Range("A2") Then
BoVorhanden = True
Exit For
End If
Next WsTabelle
If BoVorhanden Then 'Falls Kandidat schon vorhanden, Überschreiben ja / nein
If MsgBox("Kandidat ist bereits eingetragen! Überschreiben?", vbYesNo) = vbYes Then 'Ja -> alten Eintrag löschen und neu eintragen
'Sheets("Sheets("Tabelle1").Range("A2")").Delete
Worksheets.Add.Name = Sheets("Tabelle1").Range("A2")
Tabelle1.Range("B2:B4").Copy
Tabelle2.Cells(2, Tabelle2.UsedRange.Columns.Count + 1).PasteSpecial xlPasteValues
Else
MsgBox ("Abgebrochen") 'Nein -> Abbruch
End If
Else 'Kandidat noch nicht vorhanden neues Blatt wird erstellt
Worksheets.Add.Name = Sheets("Tabelle1").Range("A2")
Tabelle1.Range("B2:B4").Copy
Tabelle2.Cells(2, Tabelle2.UsedRange.Columns.Count + 1).PasteSpecial xlPasteValues
End If
Was ich bis jetzt noch nicht heraus finden konnte wie man den  Namen eines zu verwendenen Blattes aus einer Zelle ausliest
End Sub
Datei
https://www.herber.de/bbs/user/150121.xlsm
Vielen Dank

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Sheet nach Abfrage erstellen + befüllen
04.01.2022 21:12:46
Piet
Hallo
man merkt das ihr offenbar noch nicht viel Excel Erfahrung besitzt. Euer Dateiaufbau ist nicht optimal zum Daten sammeln!
Daten die man vergleichen will gehören auf ein Tabellenblatt, und nicht auf 30 Blätter verteilt, würden erfahrene Kollegen dazu sagen.
Wenn ihr trotzdem mit Einzelblätter arbeiten wollt ist es sinnvoll am Anfang eine Übersichtsliste von allen Blättern zu erstellen, die man von dort aus per Hyperlink direkt anspringen kann. Sinnvoll ist auch nicht ein neues Blatt mit ADD einfügen und ausfüllen, sondern sich ein Vorlageblatt zu erstellen, das bereits fertig ausgefüllt ist, und nur kopiert wird. Wenn du vorher den neuen Namen in der Übersicht festlegst kann man das Blatt aus der aktiven Zelle direkt umbenennen.
Ich warte mal ab was ihr zu meinem Vorschlag sagt.
mfg Piet
Anzeige
AW: Sheet nach Abfrage erstellen + befüllen
05.01.2022 09:02:49
Björn
Danke Piet für deine Antwort,
Anscheinend sind meine Excelfähigkeiten besser als meine Beschreibungsfähigkeiten, denn an eine Gesamttabelle haben wir gedacht. Die hies in der Datei nur Tabelle 2, aber ich habe die Datei noch einmal neu strukturiert und besser benannt. Die Dummy-Idee habe ich einmal umgesetzty, sowie ich sie verstanden haben. Und das Skript läuft, bis auf einen Punkt ganz gut. Ich freue mich auf Hinweise.
Der Punkt der noch nicht funktioniert ist die Ausführung des Überschreibens.
Hierzu müssten folgende Dinge erledigt werden
Das Sheet mit der Kandidatenbezeichnung, hier im Beispiel 1,2,3,4 müsste gefunden und gelöscht werden.
Im Sheet Gesamt muss in der Zeile 2, die Kandidatenbezeichnung gefunden werden und alle Zeilen darunter geleert werden.
Hierfür fehlt mir noch die Idee.
Danach geht der normale Kopierlauf los.
https://www.herber.de/bbs/user/150155.xlsm

Sub test()
Dim lngZiel As Long
Dim Kandidat As String
Dim BoVorhanden As Boolean
Dim WsTabelle As Worksheet
'Skript soll nur die Werte aus Bereich Tabelle1 B2:B4 in Tabelle2 die erste freie Spalte kopieren
'und nur die Werte aus Tabelle 1 A2:B4 in ein neues Tabellenblatt mit Namen aus Tabelle1 A2 kopieren
'im Falle eines schon vorhandenen Tabellenblatts soll eine Abfrage zum Überschreiben erscheinen
Kandidat = Sheets("Tabelle1").Range("B2").Text
For Each WsTabelle In Worksheets 'Abfrage Start ob Kandidat schon eingetragen wurde
If WsTabelle.Name = Sheets("Tabelle1").Range("B2") Then
BoVorhanden = True
Exit For
End If
Next WsTabelle
If BoVorhanden Then 'Falls Kandidat schon vorhanden, Überschreiben ja / nein
If MsgBox("Kandidat ist bereits eingetragen! Überschreiben?", vbYesNo) = vbYes Then 'Ja -> alten Eintrag löschen und neu eintragen
'Sheets("Sheets("Tabelle1").Range("A2")").Delete
'Worksheets.Add.Name = Sheets("Tabelle1").Range("B2")
Tabelle1.Range("B2:B4").Copy
Sheets("Gesamt").Cells(2, Tabelle2.UsedRange.Columns.Count + 1).PasteSpecial xlPasteValues
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValues
ActiveSheet.Copy before:=Sheets("Kandidatdummy")
Sheets("Kandidatdummy (2)").Name = Sheets("Tabelle1").Range("B2").Text
Else
MsgBox ("Abgebrochen") 'Nein -> Abbruch
End If
Else 'Kandidat noch nicht vorhanden neues Blatt wird erstellt
'Worksheets.Add.Name = Sheets("Tabelle1").Range("B2")
Tabelle1.Range("B2:B4").Copy
Sheets("Gesamt").Cells(2, Tabelle2.UsedRange.Columns.Count + 1).PasteSpecial xlPasteValues
Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValues
Worksheets("Kandidatdummy").Activate
ActiveSheet.Copy before:=Sheets("Kandidatdummy")
Sheets("Kandidatdummy (2)").Name = Sheets("Tabelle1").Range("B2").Text
End If
End Sub

Anzeige
AW: Sheet nach Abfrage erstellen + befüllen
05.01.2022 21:36:42
Piet
Hallo Björn
ich mache mir nicht gerne unnötige Arbeit. Warum ein vorhandenes Blatt löschen und neu anlegen. Man braucht nur den UsedRange zu löschen und die Zellen A2:B4 neu kopieren. Ist einfacher als Blatt löschen. Prüfe bitte mal ob der Code jetzt zufriedenstellen läuft. Ich habe ihn nicht getestet, hoffe das es klappt.
mfg piet
  • 
    Sub test()
    Dim s, LSP  As Integer  '** neu eingefügt
    Dim lngZiel As Long
    Dim Kandidat As String
    Dim BoVorhanden As Boolean
    Dim WsTabelle As Worksheet
    'Skript soll nur die Werte aus Bereich Tabelle1 B2:B4 in Tabelle2 die erste freie Spalte kopieren
    'und nur die Werte aus Tabelle 1 A2:B4 in ein neues Tabellenblatt mit Namen aus Tabelle1 A2 kopieren
    'im Falle eines schon vorhandenen Tabellenblatts soll eine Abfrage zum Überschreiben erscheinen
    Kandidat = Sheets("Tabelle1").Range("B2").Text
    For Each WsTabelle In Worksheets 'Abfrage Start ob Kandidat schon eingetragen wurde
    If WsTabelle.Name = Sheets("Tabelle1").Range("B2") Then
    BoVorhanden = True:  Exit For
    End If
    Next WsTabelle
    If BoVorhanden Then 'Falls Kandidat schon vorhanden, Überschreiben ja / nein
    If MsgBox("Kandidat ist bereits eingetragen! Überschreiben?", vbYesNo) = vbYes Then
    'Ja -> alten Eintrag löschen und neu eintragen
    '**  neu eingefügt von Piet
    LSP = Sheets("Gesamt").Cells(2, 2).End(xlToLeft).Column
    Kandidat = Sheets("Tabelle1").Range("B2")
    'Kandidat in Tabelle Gesamt suchen, ggf. Fehlermeldung!
    For s = 2 To LSP + 1
    If Sheets("Gesamt").Cells(2, s) = Kandidat Then Exit For
    Next AC
    'Kandidat in Tabelle Gesamt nicht gefunden = Fehlermeldung!
    If s > LSP Then MsgBox kasndidat & "  Kandidat in Gesamt nicht gefunden! - Bitte prüfen. Abbruch": Exit Sub
    'Wenn alles Okay fertig bearbeiten
    '** Statt Tabelle löschen nur UsedRange löschen und neu laden
    WsTabelle.UsedRange.ClearContents
    Tabelle1.Range("B2:B4").Copy
    WsTabelle.Cells(2, 2).PasteSpecial xlPasteValues
    Sheets("Gesamt").Cells(2, s).PasteSpecial xlPasteValues
    Else
    MsgBox ("Abgebrochen") 'Nein -> Abbruch
    End If
    Else 'Kandidat noch nicht vorhanden neues Blatt wird erstellt
    'Worksheets.Add.Name = Sheets("Tabelle1").Range("B2")
    Tabelle1.Range("B2:B4").Copy
    Sheets("Gesamt").Cells(2, Tabelle2.UsedRange.Columns.Count + 1).PasteSpecial xlPasteValues
    Sheets("Kandidatdummy").Cells(2, 2).PasteSpecial xlPasteValues
    Worksheets("Kandidatdummy").Copy before:=Sheets("Kandidatdummy")
    Sheets("Kandidatdummy (2)").Name = Sheets("Tabelle1").Range("B2").Text
    End If
    End Sub
    

  • Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige