VBA Zeilen in andere Tab kopieren

Sub Zuordnen() 

QTabelle = "Tab1" 

QAbZeile = 2 'Daten ab Zeile 2 in 

QSpalte = 1 'Spalte "A" 

With Worksheets(QTabelle) 'Quelltabelle vorgeben 

    QZeile = QAbZeile 'in "AbZeile" beginnen 

    Nr = .Cells(QZeile, QSpalte).Value 'Nr auslesen 

    Do While Nr <> "" 'Schleife, solange noch Daten vorhanden sind 

        'Kennzeichen "Berich" prüfen und entsprechende Tabelle zuordnen 

        Berich = .Cells(QZeile, QSpalte + 3).Value 

        Select Case Berich 

        Case "K/E" 

            ZTabelle = "Tab2" 

        Case "K/M" 

            ZTabelle = "Tab3" 

        Case Else 

            ZTabelle = "" 

        End Select 

        If ZTabelle <> "" Then 'passendes Kennzeichen gefunden 

            Tage = Val(.Cells(QZeile, QSpalte + 2).Value) 'Tageanzahl lesen 

            'Zugeordnete Spalte lt Tageanzahl ermitteln 

            ZSpalte = Switch(Tage <= 100, "B", Tage < 250, "C", Tage <= 500, "D", Tage <= 750, "E", Tage <= 1000, "F", Tage > 1000, "G") 

            'Nächste freie Zelle in der entsprechenden Spalte suchen 

            ZZeile = Worksheets(ZTabelle).Cells(65536, ZSpalte).End(xlUp).Row + 1 

            Worksheets(ZTabelle).Cells(ZZeile, ZSpalte).Value = Nr 'Nr eintragen 

        Else ' passendes Kennzeichen nicht gefunden 

            MsgBox "Für Nr " & Nr & " (siehe Zeile " & QZeile & ") konnte keine Zuordnung zu einer Zieltabelle vorgenommen werden!" 

            'Exit Sub 'Abbruch 

        End If 

        QZeile = QZeile + 1 'nächste Datenteile 

        Nr = .Cells(QZeile, QSpalte).Value 'Nr auslesen 

    Loop 

End With 

MsgBox "Fertig." 

End Sub

Sub Erstellen() 

QTabelle = "Tab1" 

QAbZeile = 2 'Daten ab Zeile 2 in 

QSpalte = "D" 

'Kennzeichen auslesen 

Kennzeichen = "#" 'Variable vorbelegen, damit auch der erste Eintrag "links" abgegrenzt ist 

With Worksheets(QTabelle) 'Quelltabelle vorgeben 

    QZeile = QAbZeile 'in "AbZeile" beginnen 

    K = .Cells(QZeile, QSpalte).Value 'Kennzeichen auslesen 

    Do While K <> "" 'Schleife, solange noch Daten vorhanden sind 

        If InStr(Kennzeichen, "#" & K & "#") = 0 Then 'noch nicht in den gesammelten Kennzeichen enthalten 

            Kennzeichen = Kennzeichen & Replace(K, "/", "_") & "#" 'aktuelles Kennzeichen hinzufügen (dabei "/" durch "_" ersetzen) 

        End If 

        QZeile = QZeile + 1 'nächste Datenteile 

        K = .Cells(QZeile, QSpalte).Value 'Kennzeichen auslesen 

    Loop 

End With 

'Tabellen erstellen 

Kenn = Split(Mid(Kennzeichen, 2, Len(Kennzeichen) - 2), "#") 'Array erzeugen (vorweg die Begrenzungszeichen an Anfang und Ende eliminieren) 

For Each SheetName In Kenn 'alle Kennzeichen durchgehen 

    IsNew = True 'Schalter; zeigt an, ob Tabellenblatt erstellt werden kann 

    For Each ExistingSheet In Worksheets 'alle bestehenden Tabellenblätter durchgehen und ... 

        If LCase(ExistingSheet.Name) = LCase(SheetName) Then '... überprüfen, ob ein gleichnamiges Blatt bereits vorhanden ist 

            IsNew = False 'Falls ja: Schalter setzen und ... 

            Exit For '... Überprüfung abbrechen 

        End If 

    Next 

    If IsNew Then 'Wenn Blatt mit dem geprüften Namen noch nicht vorhanden ist, ... 

        Set NewSheet = Worksheets.Add(After:=Sheets(Sheets.Count)) '... neues Tabellenblatt am Ende der Mappe hinzufügen und ... 

        NewSheet.Name = SheetName '... entsprechend benennen 

    End If 

Next 

Set NewSheet = Nothing 

End Sub

'Snip...... 

For Each SheetName In Kenn 

    Set NewSheet = Nothing 

    On Error Resume Next:  Set NewSheet = Sheets(SheetName):  On Error GoTo 0 

    If NewSheet Is Nothing Then 

        Set NewSheet = Worksheets.Add(After:=Sheets(Sheets.Count)):  NewSheet.Name = SheetName 

    End If 

Next 

'Snip......