Thema: Anlegen von Tabellenblättern gem. Namensliste

StandardModule: basMain

Sub NachNamenKopieren()
   Dim wks As Worksheet, wksTarget As Worksheet
   Dim iRow As Integer, iRowT As Integer
   Application.ScreenUpdating = False
   Set wks = ActiveSheet
   iRow = 1
   Do Until IsEmpty(wks.Cells(iRow, 1))
      If Left(wks.Cells(iRow, 1).Value, 4) = "name" Then
         On Error Resume Next
         Set wksTarget = Worksheets(wks.Cells(iRow, 1).Value)
         If Err > 0 Or wksTarget Is Nothing Then
            Err.Clear
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = wks.Cells(iRow, 1).Value
            Set wksTarget = ActiveSheet
            iRowT = 0
         Else
            iRowT = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row
         End If
         On Error GoTo 0
         iRow = iRow + 1
         Do Until Left(wks.Cells(iRow, 1).Value, 4) = "name"
            iRowT = iRowT + 1
            wksTarget.Cells(iRowT, 1).Value = wks.Cells(iRow, 1).Value
            iRow = iRow + 1
            If IsEmpty(wks.Cells(iRow, 1)) Then Exit Do
         Loop
      End If
   Loop
   wks.Select
   Application.ScreenUpdating = True
End Sub

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