Hilfe bei Excel-Makro mit Fehler - Arbeitsblätter autom. erstellen und ausfüllen

Option Explicit


Sub BlaetterAusLagerliste()
  Dim intLine As Long, intMaxLine As Long, intStartLine As Long, intEndLine As Long, intSheetNo As Long
  Dim rngMuster As Range, rngDaten As Range
  Dim strWorkSheet As String
  
  strWorkSheet = "Lagerliste_1002_1340_201211"  
  
  With Sheets(strWorkSheet)
    Set rngMuster = .Rows(1)
    intMaxLine = .Cells(.Rows.Count, 1).End(xlUp).Row
    
    For intLine = 2 To intMaxLine
      'Kontrolle ob Arbeitsblatt mit dem aktuellen Namen bereits existiert  
      For intSheetNo = 1 To Sheets.Count
        If Sheets(intSheetNo).Name = CStr(.Cells(intLine, 10)) Then
          MsgBox "Blatt '" & .Cells(intLine, 10) & "' bereits vorhanden.", vbInformation  
          Exit For
        End If
      Next intSheetNo
      
      intStartLine = intLine
      intEndLine = intLine
      
      'letzte Zeile suchen, die zum aktuellen Namen gehört  
      While Worksheets(strWorkSheet).Cells(intEndLine + 1, 10) = Empty And intEndLine < intMaxLine
        intEndLine = intEndLine + 1
      Wend
      
      Set rngDaten = Worksheets(strWorkSheet).Range(Cells(intStartLine, 1), Cells(intEndLine, 7))
      
      'Wenn noch kein Arbeitsblatt mit dem aktuellen Namen existiert die zugehörigen Zellen speichern  
      If intSheetNo > Sheets.Count Then
        Worksheets.Add after:=Sheets(Sheets.Count)          'Erstellt neues Arbeitsblatt  
        ActiveSheet.Name = CStr(.Cells(intStartLine, 10))   'Umbenennen auf den aktuellen Namen  
        ActiveSheet.Cells(2, 10) = .Cells(intStartLine, 10) 'Kopiert den aktuellen Namen  
        rngMuster.Copy ActiveSheet.Cells(1, 1)              'Kopiert 1. Zeile ins neue Arbeitsblatt  
        rngDaten.Copy ActiveSheet.Cells(2, 1)               'Kopiert zugehörige Zellen ins neue Arbeitsblatt  
      End If
      
      intLine = intEndLine
    Next intLine
  End With
End Sub

Option Explicit

Private Const RowsStart = 2

Sub BlaetterAusLagerliste()
    Dim Wks As Worksheet, Cell As Range, RowsEnd As Long, RowsCopyEnd As Long

    With Sheets("Lagerliste_1002_1340_201211")  
        RowsEnd = .Cells(.Rows.Count, "A").End(xlUp).Row    'Letzte Zeile in Spalte A  
        
        For Each Cell In .Range(.Cells(RowsStart, "J"), .Cells(RowsEnd, "J"))   'Alle Zellen in Spalte J  
            If Cell.Text <> "" Then     'Test Zelle nicht Leer  
                Set Wks = Nothing       'Sheet Is Nothing  
                
                'Fehlerbehandlung Aus, Set Sheet, Fehlerbehandlung wieder Ein  
                On Error Resume Next:  Set Wks = Sheets(Cell.Text):  On Error GoTo 0
                
                If Wks Is Nothing Then  'Test Sheet noch nicht vorhanden  
                    Worksheets.Add After:=Sheets(Sheets.Count) 'Erstellt neues Arbeitsblatt  
                    ActiveSheet.Name = Cell.Text    'Sheetnamen vergeben  
                    RowsCopyEnd = Cell.End(xlDown).Row - 1  'Nächste Zeile mit Inhalt - 1  
                    If RowsCopyEnd > RowsEnd Then RowsCopyEnd = RowsEnd 'Test Ende erreicht  
                   .Rows(1).Copy Rows(1)    'Kopie Zeile 1 und Zellen Spalte A:G  
                   .Range(.Cells(Cell.Row, "A"), .Cells(RowsCopyEnd, "G")).Copy Cells(RowsStart, "A")  
                Else
                    MsgBox "Blatt '" & Cell.Text & "' bereits vorhanden.", vbInformation, "Hinweis..."  
                End If
            End If
        Next
    End With
End Sub