Hinweise zu den Beispielen finden Sie hier: Home: VBA-Beispiele
Kategorie: Mappe ▸ Tabellen
Ich möchte, daß sich bestimmte Makros nur auf Worksheet xxx eines Workbooks auswirken. Wie lautet die Syntax?
Am einfachsten und sichersten ist es natürlich, im relevanten Code das enstprechende Blatt direkt anzusprechen:
Sheets("xxx").irgendwas
Soll geprüft werden, ob es sich beim aktiven Blatt um das Blatt XXX handelt, ist dies möglich:
If ActiveSheet.Name = "XXX" Then ...
Kategorie: Mappe ▸ Tabellen
Die Tabellenblätter einer Mappe sind mit Tab1, Tab2, ..., Tab50, Tab51, usw. durchnummeriert. Wie kann ich sie sortieren?
Zum Sortieren der Blätter gibt es verschiedene Möglichkeiten, was auch etwas von den Rahmenbedingungen abhängig ist. Was soll zum Beispiel mit Blättern passieren, deren Namen nicht der Syntax der zu sortierenden Blattnamen entsprechen? Hier sind drei Beispiele, die ggf. noch angepasst werden müssen.
In dem Fall werden unterwegs (also nicht am Anfang) Blätter mit Namen, die nicht der Syntax entsprechen, nach hinten verschoben - ansonsten wird so lange sortiert, bis die Zahl im folgenden Blattnamen nicht mehr gößer ist:
Sub BlaetterSortieren() Dim bolSortiert As Boolean Dim intBlatt As Integer, intBlatt1 As Integer Dim varAkt, varNaechst bolSortiert = False Do While bolSortiert = False bolSortiert = True For intBlatt = 1 To Sheets.Count varAkt = Replace(Sheets(intBlatt).Name, "Tab", "") If IsNumeric(varAkt) Then For intBlatt1 = intBlatt To Sheets.Count varNaechst = Replace(Sheets(intBlatt1).Name, "Tab", "") If IsNumeric(varNaechst) Then If varNaechst * 1 < varAkt * 1 Then Sheets(intBlatt1).Move Before:=Sheets(intBlatt) bolSortiert = False End If Else Sheets(intBlatt1).Move after:=Sheets(Sheets.Count) End If Next End If Next Loop End Sub
Ein Beispiel mit Sprungmarken, Reihenfolge Tab1, Tab2, Tab11:
Sub Blattsort() Dim intAnzahl As Integer, intN As Integer, intM As Integer, intI As Integer, intZahlM As Integer, intZahlN As Integer Dim WS As Worksheet intAnzahl = ActiveWorkbook.Worksheets.Count For intM = 1 To intAnzahl For intN = intM To intAnzahl On Error Resume Next For intI = 1 To Len(Worksheets(intN).Name) If IsNumeric(Right(Worksheets(intN).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlN = Right(Worksheets(intN).Name, intI) Exit For End If Next intI For intI = 1 To Len(Worksheets(intM).Name) If IsNumeric(Right(Worksheets(intM).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlM = Right(Worksheets(intM).Name, intI) Exit For End If Next intI If CInt(intZahlN) < CInt(intZahlM) Then Worksheets(intN).Move Before:=Worksheets(intM) GoTo NAECHSTE TEXT: If Worksheets(intN).Name < Worksheets(intM).Name Then Worksheets(intN).Move Before:=Worksheets(intM) NAECHSTE: Next intN Next intM MsgBox "Anzahl der Tabellen: " & intAnzahl End Sub
Ein kurzes Beispiel, aber die Reihenfolge ist Tab1, Tab11, Tab2:
Sub Blattsort1() Dim intX As Integer Dim bolY As Boolean Do bolY = True For intX = 1 To Sheets.Count - 1 If Sheets(intX).Name > Sheets(intX + 1).Name Then Sheets(intX + 1).Move Before:=Sheets(intX) bolY = False End If Next intX Loop Until bolY = True End Sub
Kategorien: Programmiertechnik ▸ Darstellung und Tabelle ▸ Selection
Wie kann ich erreichen, daß ein Makro nicht alle einzelnen Schritte anzeigt?
Dazu kann die Bildschirmaktualisierung (das ScreenUpdating) ausgeschaltet werden:
Application.ScreenUpdating = False
Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
Das Ausschalten der Bildschirmaktualisierung hat auch immer ein paar Risiken, denn das Excelfenster ist ja dann „eingefroren“. Kommt es zu einem Fehler durch den Code, bleibt das Fenster auch eingefroren - der Anwender sieht dann schlicht keine Veränderungen mehr. Deshalb ist empfehlenswert, durch objektorientiertes Arbeiten (also Elemente direkt ansprechen, Verzicht auf .Select und .Activate) dafür zu sorgen, dass der Bildschirm nicht zappelt.
Soll die Aktualisierung trotzdem ausgeschaltet werden (weil vielleicht die Laufzeit kürzer wird), sollten Fehler abgefangen und per Sprungmarke am Ende des Codes die Bildschirmaktualisierung wieder eingeschaltet werden. Im einfachsten Fall wäre das so möglich:
On Error GoTo FEHLER … Code … FEHLER: Application.ScreenUpdating = True
Günstig ist auch, am Anfang den Status der Eigenschaft abzufragen und sie am Ende wieder so zu setzen, wie sie am Anfang war:
Sub MeinMakro() Dim bolAktScrUpd As Boolean bolAktScrUpd = Application.ScreenUpdating … Code … Application.ScreenUpdating = bolAktScrUpd End Sub
Kategorie: Mappe ▸ Tabellen
Wie kann ich ein neues Blatt einfügen? Dabei soll überprüft werden, ob ein Blatt mit dem Namen schon existiert und der linke und rechte Seitenrand auf einen Zentimeter festgelegt werden.
In eine Inputbox kann der Name des zu erzeugenden Blattes eingetragen werden. Anschließend wird mit einer Schleife geprüft, ob der Name schon vergeben ist. Wenn nicht, wird das Blatt eingefügt und die Seitenränder werden festgelegt.
Sub Blatterstellen() Dim wksBlatt As Object Dim strNeu As String strNeu = InputBox("Bitte Namen des neuen Arbeitsblattes eingeben:") For Each wksBlatt In ActiveWorkbook.Sheets If wksBlatt.Name = strNeu Then MsgBox "Blattname existiert bereits!", vbOKOnly + vbExclamation, "Blatt hinzufügen" Exit Sub End If Next Sheets.Add ActiveSheet.Name = strNeu With Sheets(strNeu).PageSetup .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) End With End Sub
Eine andere Möglichkeit, bei der auch gleich festgelegt wird, wo das Blatt eingefügt werden soll:
Sub Blatterstellen1() Dim wksBlatt As Object Dim strNeu As String strNeu = InputBox("Bitte Namen des neuen Arbeitsblattes eingeben:") For Each wksBlatt In ActiveWorkbook.Sheets If wksBlatt.Name = strNeu Then MsgBox "Blattname existiert bereits!", vbOKOnly + vbExclamation, "Blatt hinzufügen" Exit Sub End If Next Set wksBlatt = Sheets.Add(before:=Sheets(1)) wksBlatt.Name = strNeu With wksBlatt.PageSetup .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) End With End Sub
Kategorie: Mappe ▸ Handling
Wie kann ich per Makro eine Datei schließen?
Datei schließen ohne zu speichen: ACHTUNG: Änderungen werden nicht berücksichtigt!
Sub DateiSchliessen() Workbooks("MeineDatei.xlsx").Close SaveChanges:=False End Sub
Datei schließen mit speichern:
Sub DateiSchliessen() Workbooks("MeineDatei.xlsx").Close SaveChanges:=True End Sub
In diesem Beispiel werden alle geöffneten Arbeitsmappen geschlossen. Bei Änderungen öffnet Excel den Dialog zum Speichern der Änderungen.
Sub DateiSchliessen() Workbooks.Close End Sub
Kategorien: Dateien und Ordner ▸ Dateioperation und Mappe ▸ Tabellen
Auf dem Blatt "Huber" steht in A10 der Pfad und der Name der Datei "Ablage.xls". In diese Datei möchte ich das Blatt "Huber" kopieren. Das Blatt soll in der Datei als letztes erscheinen; diese soll anschließend geschlossen werden.
Eigentlich wäre es mit diesem (sicher selbst erklärendem) Code getan:
Dim strPfad As String, strDatei As String strPfad = ThisWorkbook.Sheets("Huber").Range("A10") strDatei = Dir(strPfad) Workbooks.Open Filename:=strPfad ThisWorkbook.Sheets("Huber").Copy after:=Workbooks(strDatei).Sheets(Sheets.Count) Workbooks(strDatei).Close True
Wenn es da nicht ein paar Fehleranfälligkeiten geben würde:
Wenigstens diese Fragen sollten im Code noch geklärt werden, damit es keine Fehlermeldungen durch Excel und Abbrüche gibt. Anhand der Variablennamen sollte deutlich werden, was im Code passiert:
Sub Blatt_kopieren() Dim strPfad As String, strDatei As String Dim bolOffen As Boolean Dim objMappe As Object, objBlatt As Object strPfad = ThisWorkbook.Sheets("Huber").Range("A10") strDatei = Dir(strPfad) If strDatei = "" Then MsgBox "Datei existiert nicht" Exit Sub End If bolOffen = False For Each objMappe In Workbooks If objMappe.Name = strDatei Then bolOffen = True Exit For End If Next If bolOffen = False Then Workbooks.Open Filename:=strPfad For Each objBlatt In Workbooks(strDatei).Sheets If objBlatt.Name = "Huber" Then MsgBox "In der Zieldatei existiert bereits ein Blatt mit dem Namen 'Huber'.", vbOKOnly + vbExclamation, "Blatt existiert" If bolOffen = False Then Workbooks(strDatei).Close False Exit Sub End If Next ThisWorkbook.Sheets("Huber").Copy after:=Workbooks(strDatei).Sheets(Sheets.Count) Workbooks(strDatei).Close True End Sub
Kategorie: Mappe ▸ Tabellen
Wie kann ich die Summe von A1 aus jedem Blatt bilden?
Beispielsweise durch eine Schleife über die Blätter der Mappe:
Sub Addieren() Dim dblSummen As Double, intI As Integer dblSummen = 0 For intI = 1 To Worksheets.Count dblSummen = dblSummen + Worksheets(intI).Range("A1") Next MsgBox dblSummen End Sub
Kategorie: Mappe ▸ Tabellen
Ich habe mehrere Blätter mit Daten. Alle Blätter haben unterschiedlich viele Datensätze (Datenzeilen). Alle Daten sollen nacheinander auf einem Blatt zusammengefaßt werden.
Der Code löscht zunächst das Blatt Zusammenfassung, falls es existiert. Alternativ können natürlich auch Zellen oder Zellinhalte dieses Blattes gelöscht werden.
Anschließend läuft im Beispiel eine Schleife über die ersten drei Tabellenblätter. Von denen werden die Zellen in den Spalten 1 bis 5 bis zur letzten (in Spalte 1) ausgefüllten Zeile genommen und untereinander auf das Blatt Zusammenfassung kopiert.
Sub speichern() Dim lngZeile As Long, lngLetzteZ As Long, bytI As Byte Dim strBereich As String On Error Resume Next Worksheets("Zusammenfassung").Delete 'Auswertungsblatt löschen On Error GoTo 0: Err.Clear Worksheets.Add after:=Sheets(Sheets.Count) 'Auswertungsblatt einfügen ActiveSheet.Name = "Zusammenfassung" 'Variable, die dafür sorgt, daß die zusammengefaßten Daten untereinander stehen lngZeile = 1 'hier ab Zeile 1 For bytI = 1 To 3 'Von Blatt 1 bis Blatt 3 zusammenfassen lngLetzteZ = Worksheets(bytI).Cells(Worksheets(bytI).Rows.Count, 1).End(xlUp).Row strBereich = Range(Cells(1, 1), Cells(lngLetzteZ, 5)).Address 'Datenbereich (hier bis Spalte 5) auswählen Worksheets(bytI).Range(strBereich).Copy Sheets("Zusammenfassung").Cells(lngZeile, 1) 'Variable Zeile erhöhen lngZeile = lngZeile + lngLetzteZ Next End Sub
Kategorie: Anwendung
Wie kann ich die Titelleiste von Excel ändern?
Die Titelleiste der Anwendung kann man ändern mit:
Application.Caption = "So wie Du willst"
Zurücksetzen:
Application.Caption = Empty
Die Titelleiste der Mappe kann man einrichten mit:
ActiveWindow.Caption = "Ich bin ein Fenster."
Kategorie: Anwendung
Wie kann ich per Makro Excel beenden, ohne daß gefragt wird, ob die Änderungen gespeichert werden?
Suggeriert, dass die Datei gespeichert ist (wenn nicht gespeichert werden soll) und beendet Excel ohne nachzufragen:
ThisWorkbook.Saved = True Application.Quit
Speichert erst und beendet Excel:
ThisWorkbook.Save Application.Quit
Ansonsten ist auch eine Schleife möglich, wenn mehrere Mappen offen sind, die gespeichert werden sollen:
Sub AnwendungBeenden() Dim wb As Workbook For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name Then wb.Close True Next Application.Quit End Sub
Wie zu sehen ist, darf die Mappe mit dem Code bei der Schleife noch nicht geschlossen werden, weil sonst die Routine weg ist und der Rest nicht mehr ausgeführt wird. Die muss also zuletzt dran glauben; ggf. kann auch die noch gespeichert werden.
Kategorien: Dateien und Ordner ▸ Dateioperation und Ereignisse ▸ Mappe
Wie kann ich beim Vorhandensein einer Mappe eine neue ohne Fehlermeldung unter dem Namen der alten speichern?
Um eine Datei ohne Fehlermeldung zu überschreiben, kann der Code verwendet werden:
Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:="g:\Test\Test.xls" Application.DisplayAlerts = True
Ob das ein guter Stil ist, sei jedem selbst überlassen …
Kategorie: Suchen/Ersetzen
Wie kann ich auf allen zur Mappe gehörenden Blättern suchen und ersetzen?
In Inputboxen werden zu suchender Text und neuer Text eingegeben. Anschließend wird auf jedem Tabellenblatt der Mappe die Ersetzung durchgeführt.
Sub suchersetz() Dim strSuchBegriff As String, strErsetzBegriff As String Dim wks As Worksheet strSuchBegriff = Application.InputBox("Bitte den zu suchenden Begriff eingeben") strErsetzBegriff = Application.InputBox("Bitte den Ersatzbegriff eingeben") For Each wks In ActiveWorkbook.Worksheets wks.UsedRange.Replace what:=strSuchBegriff, replacement:=strErsetzBegriff, lookat:=xlPart, searchOrder:=xlByColumns, MatchCase:=False Next End Sub
Ggf. kann hier noch eine Fehlerbehandlung eingebaut werden, wenn zum Beispiel eine InputBox abgebrochen wurde.
Kategorie: Interaktion ▸ Dialoge
Die integrierten Dialogfelder von Excel können auch mit VBA aufgerufen werden. Dies geschieht einfach mit:
Application.Dialogs(Konstante).Show
Bei den Dialogfeldern können verschiedene Argumente mitgegeben werden, die natürlich bei jedem Element anders sind. Hierzu am besten einfach in die Hilfe sehen.
Manchmal muss man sich entscheiden, ob ein integriertes Dialogfeld oder ein herkömmliches Dialogfeld für die Aufgabe besser geeignet ist. Mit z. B. Application.GetOpenFilename kann schön der Pfad abgefragt werden, was mit xlDialogOpen schon nicht mehr so einfach ist.
lfd. Nr. | Konstante | Name |
---|---|---|
1 | xlDialogActivate | Aktivieren |
2 | xlDialogActiveCellFont | Schrift |
3 | xlDialogAddinManager | Add-In-Manager |
4 | xlDialogAlignment | Ausrichtung |
5 | xlDialogApplyStyle | Formatvorlage |
6 | xlDialogArrangeAll | Fenster anordnen |
7 | xlDialogAutoCorrect | Autokorrektur |
8 | xlDialogBorder | Rahmen |
9 | xlDialogCalculation | Beschriftungsoptionen |
10 | xlDialogCellProtection | Zellschutz |
11 | xlDialogClear | Inhalte löschen |
12 | xlDialogColorPalette | Farboptionen |
13 | xlDialogColumnWidth | Spaltenbreite |
14 | xlDialogConditionalFormatting | Bedingte Formatierung |
15 | xlDialogConsolidate | Konsolidierung |
16 | xlDialogCopyPicture | Bild kopieren |
17 | xlDialogCreateNames | Namen erstellen |
18 | xlDialogCustomizeToolbar | Anpassen |
19 | xlDialogCustomViews | Ansichten |
20 | xlDialogDataSeries | Reihe |
21 | xlDialogDefineName | Namen definieren |
22 | xlDialogDefineStyle | Formatvorlage |
23 | xlDialogDeleteFormat | Zahlenformat |
24 | xlDialogDeleteName | Namen definieren |
25 | xlDialogDemote | Gruppierung |
26 | xlDialogDisplay | Bildschirmanzeigeoptionen |
27 | xlDialogEditDelete | Zellen löschen |
28 | xlDialogFileDelete | Datei löschen |
29 | xlDialogFileSharing | Arbeitsmappe freigeben |
30 | xlDialogFilterAdvanced | Spezialfilter |
31 | xlDialogFindFile | Datei suchen/öffnen |
32 | xlDialogFormatAuto | Autoformat |
33 | xlDialogFormatNumber | Zahlenformat |
34 | xlDialogFormulaFind | Suchen |
35 | xlDialogFormulaGoto | Gehe zu |
36 | xlDialogFormulaReplace | Ersetzen |
37 | xlDialogGoalSeek | Zielwertsuche |
38 | xlDialogImportTextFile | Textdatei importieren |
39 | xlDialogInsert | Zellen einfügen |
40 | xlDialogInsertHyperlink | Hyperlink einfügen |
41 | xlDialogInsertNameLabel | Beschriftungsbereiche |
42 | xlDialogInsertObject | Objekt einfügen |
43 | xlDialogInsertPicture | Bild einfügen |
44 | xlDialogNew | Datei - Neu |
45 | xlDialogOpen | Datei öffnen |
46 | xlDialogOptionsCalculation | Optionen: Berechnung |
47 | xlDialogOptionsEdit | Optionen: Bearbeitung |
48 | xlDialogOptionsGeneral | Optionen: Allgemein |
49 | xlDialogOptionsListsAdd | Optionen: Liste |
50 | xlDialogOptionsTransition | Optionen: Umsteigen |
51 | xlDialogOptionsView | Otionen: Ansicht |
52 | xlDialogPageSetup | Seite einrichten |
53 | xlDialogPasteSpecial | Inhalte einfügen |
54 | xlDialogPatterns | Format: Muster |
55 | xlDialogPrint | |
56 | xlDialogPrinterSetup | Druckereinrichtung |
57 | xlDialogProperties | Dateieigenschaften |
58 | xlDialogProtectDocument | Blatt schützen |
59 | xlDialogRoutingSlip | Mailverteiler |
60 | xlDialogRowHeight | Zeilenhöhe |
61 | xlDialogRun | Makro |
62 | xlDialogSaveAs | Speichern unter |
63 | xlDialogSelectSpecial | Inhalte auswählen |
64 | xlDialogSendMail | Mappe als Mail |
65 | xlDialogSetBackgroundPicture | Hintergrundbild |
66 | xlDialogSetPrintTitles | Drucktitel |
67 | xlDialogSort | Sortieren |
68 | xlDialogUnhide | Tabelle einblenden |
69 | xlDialogWorkbookAdd | Blatt verschieben/kopieren |
70 | xlDialogWorkbookName | Blatt umbenennen |
71 | xlDialogWorkbookNew | Tabelle usw. einfügen |
72 | xlDialogWorkbookProtect | Arbeitsmappe schützen |
73 | xlDialogZoom | Zoom |
Kategorien: Mappe ▸ Tabellen und Tabelle ▸ Matrix
Auf einem Tabellenblatt befinden sich in Spalte C die Namen der Mitarbeiter, daneben ihre Daten. Für jeden Mitarbeiter kann es mehrere Zeilen geben. Wie kann ich für jeden Mitarbeiter ein neues Blatt per VBA erstellen, auf dem seine Daten untereinander aufgelistet sind?
Ein Lösungsansatz, der allerdings erst ab Excel 365 funktioniert, ist der Einsatz dynamischer Arrayfunktionen. Dadurch können die Daten vorgefiltert werden und per Schleife müssen nur noch die jeweiligen Ergebnismengen verarbeitet werden; eine Schleife über alle Zeilen ist nicht notwendig.
Gegeben ist die Tabelle mit den Namen in Spalte C ab Zeile 2 und Daten bis zur Spalte G. Dies müsste ggf. angepasst werden. Die letzte Zeile der Tabelle wird aufgrund der Daten in C automatisch erkannt.
Zuerst kommt die Tabellenblattfunktion EINDEUTIG() (UNIQUE()) zum Zug. Sie enthält jeden Namen aus Spalte C genau einmal. Dies ist wichtig, da für jeden Mitarbeiter ja nur ein Blatt erstellt werden soll. Über das Ergebnis dieser Formel kann dann die Hauptschleife laufen: For Each varName In varNamen
In der Schleife wird dann für jeden Namen wieder eine Arrayfunktion verwendet: FILTER(). Diese liefert einen Array, der bei mehreren Zeilen zum Mitarbeiter aus diesen Zeilen mit den Zellen besteht oder bei nur einer Zeile aus den einzelnen Zellen. Damit hier kein Fehler auftritt, wird mit If UBound(varFilt) = Application.WorksheetFunction.CountA(varFilt) Then geprüft, wie viele Elemente der Array hat. Ist die Größe des Arrays gleich der Anzahl der einzelnen Elemente, handelt es sich um eine Zeile; die Elemente sind die Zellen. Ist die Größe des Arrays kleiner als die Anzahl der einzelnen Elemente, handelt es sich um mehrere Zeilen.
Beispiel: Bei zwei Zeilen ist der Ubound = 2. Jede Zeile hat vier Zellen, also sind das 2 Zeilen * 4 Zellen = 8 Elemente. Ubound ist kleiner als die Anzahl der Elemente. Bei nur einer Zeile hat der Array vier Elemente (die Zellen eben). Da der Array hier nicht nach Zeilen untergliedert ist, sondern die Zellen in der ersten Ebene liegen, ist hier Ubound auch = 4.
Diese Arrayelemente werden dann nur noch auf das hinzugefügte Blatt eingelesen.
Der Code:
Sub Aufteilen_Filter() Dim lngZ As LongPtr, lngLZ As LongPtr, intZ As Integer Dim strAktBlatt As String, strFormel As String Dim wksNeu As Worksheet Dim varFilt, varNamen, varName strAktBlatt = "Mitarbeiter" lngLZ = Cells(Rows.Count, 3).End(xlUp).Row varNamen = Application.WorksheetFunction.Unique(Range("C2:C" & lngLZ)) If IsArray(varNamen) Then For Each varName In varNamen strFormel = "=FILTER(" & strAktBlatt & "!C2:G" & lngLZ & "," & strAktBlatt & "!C2:C" & lngLZ & "=""" & varName & """)" varFilt = Application.Evaluate(strFormel) If IsArray(varFilt) Then Set wksNeu = Worksheets.Add(after:=Sheets(Sheets.Count)) wksNeu.Name = varName Sheets(strAktBlatt).Range("C1:G1").Copy wksNeu.Range("C1") lngZ = 1 If UBound(varFilt) = Application.WorksheetFunction.CountA(varFilt) Then lngZ = lngZ + 1 For intS = 1 To UBound(varFilt) wksNeu.Cells(lngZ, intS + 2) = varFilt(intS) '+2 weil Spalte C Next Else For intZ = 1 To UBound(varFilt) lngZ = lngZ + 1 For intS = 1 To 5 wksNeu.Cells(lngZ, intS + 2) = varFilt(intZ, intS) Next Next End If End If Next End If End Sub
Vor Excel 365 funktioniert die Variante mit den dynamischen Arrayfunktionen noch nicht. Deshalb hier noch eine ältere Möglichkeit:
Die Routine duchläuft die Spalte der Mitarbeiternamen von oben nach unten. Mit Hilfe der ZÄHLENWENN-Funktion wird geprüft, ob sich unterhalb der gerade durchlaufenen Zelle der Name des Mitarbeiters nochmals befindet. Wenn nicht, wird ein neues Blatt mit dem Namen des Mitarbeiters angelegt und es werden die Spaltenüberschriften eingefügt.
Zum Schluss werden die Daten zu den Mitarbeitern auf deren Blättern eingetragen.
Sub Aufteilen_Schleife() Dim lngZ As Long, lngLZ As Long, intAnzahl As Integer Dim lngAktZeile As Long Dim strAktBlatt As String, strName As String Dim ints, intAnzahlTB, intAnzahlSpalten As Integer Dim objNeuBlatt As Worksheet Dim lngErsteZeile As Long Dim strSpalte As String 'Hier anpassen: lngErsteZeile = 2 strSpalte = "C" strAktBlatt = ActiveSheet.Name lngLZ = Range(strSpalte & 65536).End(xlUp).Row 'Blätter mit den Spaltenüberschriften erstellen: For lngZ = lngErsteZeile To lngLZ If Sheets(strAktBlatt).Range(strSpalte & lngZ) <> "" Then intAnzahl = Application.WorksheetFunction.CountIf(Sheets(strAktBlatt).Range(strSpalte & lngZ + 1 & ":" & strSpalte & "65536"), Sheets(strAktBlatt).Range(strSpalte & lngZ)) If intAnzahl = 0 Then Set objNeuBlatt = Worksheets.Add(after:=Sheets(Sheets.Count)) objNeuBlatt.Name = Sheets(strAktBlatt).Range(strSpalte & lngZ) For ints = 1 To Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column objNeuBlatt.Cells(1, ints) = Sheets(strAktBlatt).Cells(1, ints) Next ints End If End If Next lngZ 'Übernahme der Daten auf die einzelnen Blätter: intAnzahlSpalten = Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column For lngZ = lngErsteZeile To lngLZ strName = Sheets(strAktBlatt).Range(strSpalte & lngZ) If strName <> "" Then lngAktZeile = Sheets(strName).Range(strSpalte & 65536).End(xlUp).Row + 1 Sheets(strName).Range(Sheets(strName).Cells(lngAktZeile, 1), Sheets(strName).Cells(lngAktZeile, intAnzahlSpalten)).Value = _ Sheets(strAktBlatt).Range(Sheets(strAktBlatt).Cells(lngZ, 1), Sheets(strAktBlatt).Cells(lngZ, intAnzahlSpalten)).Value End If Next lngZ End Sub