Excel und VBA: Formeln, Programmierung, Lösungen

StandardModule: basMain

Sub Aufteilen()
   Dim wks As Worksheet, wksTarget As Worksheet
   Dim iRow As Integer, iCol As Integer, iRowL As Integer
   Set wks = ActiveSheet
   iRow = 2
   Workbooks.Add 1
   Do Until IsEmpty(wks.Cells(iRow, 1))
      On Error Resume Next
      Set wksTarget = Worksheets(wks.Cells(iRow, 1).Text)
      If Err > 0 Or wksTarget Is Nothing Then
         Err.Clear
         Worksheets.Add after:=Worksheets(Worksheets.Count)
         ActiveSheet.Name = wks.Cells(iRow, 1).Text
         Set wksTarget = ActiveSheet
         iRowL = 1
      Else
         iRowL = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
      End If
      For iCol = 1 To 3
         wksTarget.Cells(iRowL, iCol).Value = wks.Cells(iRow, iCol + 1).Value
      Next iCol
      iRow = iRow + 1
   Loop
   Application.DisplayAlerts = False
   Worksheets(1).Delete
   Application.DisplayAlerts = True
End Sub

    

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Liste