Hab hier einen Super Code gefunden um Daten von einem Tabellenblatt auf mehrere aufzuzteilen. Das heisst alle Gruppenbezeichnungen in Spalte D zusammen in ein neues Blatt. Sowiet funtkioniert da ganz gut. Nur werden nur beim letzten Blatt die leerzeilen gelöscht bei den anderen aber nicht und ausserdem bleibt die Gruppe SAM auf dem ursprünglichen Blatt stehen.
hier mal der Code und die dazugehörige Datei.
Sub Zeile_in_neues_Blatt()
'Prozedur, in der eine zu durchsuchende Spalte abgefragt wird
'Die unterschiedlichen Begriffe, die gefunden werden,
'werden je in ein neues Blatt kopiert.
'Startzeile ist 2
Dim wkbBasis As Workbook
Dim wksBasis As Worksheet
Dim wksZiel As Worksheet
Dim wks As Worksheet
Dim intBlatter As Integer
Dim lngZeil As Long
Dim intRow As Integer
Dim varSuch As Variant
Dim varSpalt As Variant
Dim bolCut As Boolean
Dim lngCZeil As Long
Dim lngPZeil As Long
varSpalt = InputBox("Bitte die Spalte eingeben, die durchsucht werden soll.", "Suchspalte", "")
If IsEmpty(varSpalt) Then Exit Sub
If Not IsNumeric(varSpalt) Then Exit Sub
If CInt(varSpalt) > 255 Or CInt(varSpalt) < 0 Then Exit Sub
varSpalt = CByte(varSpalt)
Application.EnableEvents = False
Set wkbBasis = ActiveWorkbook
Set wksBasis = ActiveSheet
lngZeil = 2
Do
varSuch = wksBasis.Cells(lngZeil, varSpalt)
If wksBasis.Name = varSuch Then Exit Sub
wkbBasis.Sheets.Add after:=wksBasis
Set wksZiel = ActiveSheet
For Each wks In wkbBasis.Worksheets
If wks.Name = varSuch Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
wksZiel.Name = varSuch
lngCZeil = 2
lngPZeil = 2
Do
If wksBasis.Cells(lngCZeil, varSpalt) = varSuch Then
wksBasis.Cells(lngCZeil, 1).EntireRow.Cut Destination:=wksZiel.Cells(lngPZeil, 1)
wksBasis.Cells(lngCZeil, 1).EntireRow.Delete
bolCut = True
End If
If bolCut = False Then
lngCZeil = lngCZeil + 1
bolCut = True
Else
lngPZeil = lngPZeil + 1
bolCut = False
End If
Loop Until IsEmpty(wksBasis.Cells(lngCZeil, varSpalt))
lngZeil = lngZeil + 1
Loop Until IsEmpty(wksBasis.Cells(lngZeil, varSpalt))
Set wksZiel = Nothing
Set wkbBasis = Nothing
Application.EnableEvents = True
End Sub
https://www.herber.de/bbs/user/40564.xls
Ich hoffe es findet jemand den Fehler den es ist sehr mühsam jedes einzelene Blatt aufzurufen und dort die leerzeilen zu löschen.
Besten Dank und Gruss
Roger