Tabelle aufteilen auf neue Dateien

[herbert0803]

Hallo,

ich habe ein Makro, dass mir eine Tabelle augfrund der Einträge in einer Spalte auf mehrere Tabellenblätter aufteilt, inkl. der Zeilen vor der Spaltenüberschrift.
Was muss geändert werden, damit nicht neue Tabellenblätter sondern neue Dateien im gleichen Verzeichnis wie die Originaldatei erstellt werden?

Code:

Sub Verantwort_Aufteilung()
   Dim AnmerkTab As Worksheet
   Dim wshTabelle As Worksheet
   Dim lngZeile As Long
   Dim lngLetzte As Long
   Dim rngZelle As Range
   Dim Spaltenüberschrift As Variant

   Set AnmerkTab = ActiveWorkbook.Worksheets("AnmerkIR")
   Spaltenüberschrift = "Verantwortliche(r)"
   
   With AnmerkTab
   .ListObjects("Anm").Sort.SortFields.Clear
   .ListObjects("Anm").Sort.SortFields.Add _
       Key:=Range("Anm[[#All],[Verantwortliche(r)]]"), SortOn:=xlSortOnValues, _
       Order:=xlAscending, DataOption:=xlSortTextAsNumbers
   End With
   With AnmerkTab.ListObjects("Anm").Sort
       .Header = xlYes
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
   ActiveSheet.ListObjects("Anm").Range.AutoFilter Field:=6, Criteria1:="N"

   With AnmerkTab
       Set rngZelle = .UsedRange.Find(Spaltenüberschrift, LookAt:=xlWhole)
       If Not rngZelle Is Nothing Then
           lngZeile = rngZelle.Row + 1
           Application.ScreenUpdating = False
           Do
               On Error Resume Next
               Set wshTabelle = Worksheets(CStr(.Cells(lngZeile, rngZelle.Column)))
               On Error GoTo 0
               If wshTabelle Is Nothing Then
                   Worksheets.Add After:=Worksheets(Worksheets.Count)
                   Set wshTabelle = Worksheets(Worksheets.Count)
                   wshTabelle.Name = .Cells(lngZeile, rngZelle.Column)
                   .Rows("1:" & rngZelle.Row).Copy wshTabelle.Range("A1")
                   
           ActiveSheet.DrawingObjects.Select   'Schaltflächen löschen
           Selection.Delete
           
           ActiveWindow.DisplayGridlines = False   'Gitternetzlinien ausblenden

               End If
               lngLetzte = IIf(IsEmpty(wshTabelle.Cells(wshTabelle.Rows.Count, rngZelle.Column)), _
                   wshTabelle.Cells(wshTabelle.Rows.Count, rngZelle.Column).End(xlUp).Row, _
                   wshTabelle.Rows.Count) + 1
               .Rows(lngZeile).Copy
               wshTabelle.Range("A" & lngLetzte).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False
       ActiveSheet.Paste
       Range("A1").Select
               lngZeile = lngZeile + 1
               Set wshTabelle = Nothing
           Loop While .Cells(lngZeile, rngZelle.Column) <> ""
           Set rngZelle = Nothing
           
       
           Application.CutCopyMode = False
           Application.ScreenUpdating = True
       End If
   End With
   
    With AnmerkTab.ListObjects("Anm")
       If .ShowAutoFilter Then
           If .AutoFilter.FilterMode Then
           .AutoFilter.ShowAllData
           End If
       End If
       .Sort.SortFields.Clear
       .Sort.SortFields.Add _
           Key:=Range("Anm[[#All],[lfd." & Chr(10) & "Nr.]]"), SortOn:=xlSortOnValues, Order:= _
           xlAscending, DataOption:=xlSortTextAsNumbers
   End With
   
   With AnmerkTab.ListObjects("Anm").Sort
       .Header = xlYes
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
   
   Application.Goto AnmerkTab.Range("A1")

   
End Sub

Danke!

[schauan]

Hallöchen,

speichere die neu erzeugten Blätter als Datei. Den Code dazu kannst Du aufzeichnen. Neues Tabellenblatt nehmen, im Kontextmenü Verschieben, in neue Datei. Anschließend die neue Datei speichern und schließen. Dann sind die auch aus Deiner Programmdatei raus.

Das Makro müsste man ggf. noch anpassen, nicht zuletzt wegen dem Dateinamen. Da helfen wir dann weiter.

[herbert0803]

Hallo Andre,

danke für den Hinweis, ich hab es dann so versucht.
Dachte nur es gibt vielleicht eine andere Möglichkeit das direkt ohne zwischenspeichern in die einzelnen Blätter zu machen.
Mein Code dafür:

Code:

Sub ArbeitsblätterSpeichern()
   
Pfadname = ThisWorkbook.Path


'Anzahl der Tabellenblätter ermitteln
Dim Anzahl As Long

Anzahl = ThisWorkbook.Worksheets.Count
Anzahl = ThisWorkbook.Sheets.Count

'Tabellenblätter mit dem Index ansprechen
Dim i As Long

For i = 3 To Anzahl
If i < 3 Then
Exit Sub
End If


Dateiname = Worksheets(3).Name

   Worksheets(3).Move
   With ActiveWorkbook
   .SaveAs Filename:=Pfadname & "\Testbezeichnung_" & Dateiname & ".xlsx"
   .Close
   End With
Next

End Sub

Kannst du kurz drüberschauan ;) ob da noch was besser gemacht werden kann. Funktionieren tut es.

[schauan]

HAllo Herbert,

du könntest das

'Anzahl der Tabellenblätter ermitteln
Dim Anzahl As Long
Anzahl = ThisWorkbook.Worksheets.Count
Anzahl = ThisWorkbook.Sheets.Count
'Tabellenbl?tter mit dem Index ansprechen
Dim i As Long
For i = 3 To Anzahl
If i < 3 Then
Exit Sub
End If

zu dem zusammenfassen:

'Bei weniger als 3 Blaettern Makro verlassen
If ThisWorkbook.Sheets.Count < 3 then Exit Sub


ThisWorkbook.Worksheets.Count wäre relevant, wenn Du auch andere Blätter in der Datei hast wie z.B. Diagrammblätter und diese nicht mitgezählt werden sollen...

[herbert0803]

Hallo Andre,

danke, werde ich so machen.

Noch eine Frage zu meinem ersten Code, der die Tabelle auf die Tabellenblätter aufteilt.
Es wird eine bestimmte Spalte (wird aufgrund der Spaltenüberschrift definiert) durchlaufen und alle Zeilen mit dem gleichen Wert in dieser Spalte in ein neues Tabellenblatt kopiert.
Mein Problem ist nun, dass ich einen Filter setze und dadurch Zeilen ausgeblendet werden.
Dass nur die sichtbaren Zeilen kopiert werden habe ich geschafft.
Aber es wird auch ein neues Tabellenblatt erzeugt, für Werte wo alle Zeilen ausgeblendet sind. Wie kann ich das umgehen?
Vielleicht kannst du mir da auch helfen.
Ich weiß nicht ob ich mich verständlich ausgedrückt habe.
Ich kopiere den Code hier nochmals rein.

Code:

Sub Verantwort_Aufteilung()
  Dim AnmerkTab As Worksheet
  Dim wshTabelle As Worksheet
  Dim lngZeile As Long
  Dim lngLetzte As Long
  Dim rngZelle As Range
  Dim Spaltenüberschrift As Variant

  Set AnmerkTab = ActiveWorkbook.Worksheets("AnmerkIR")
  Spaltenüberschrift = "Verantwortliche(r)"
 
  With AnmerkTab
  .ListObjects("Anm").Sort.SortFields.Clear
  .ListObjects("Anm").Sort.SortFields.Add _
      Key:=Range("Anm[[#All],[Verantwortliche(r)]]"), SortOn:=xlSortOnValues, _
      Order:=xlAscending, DataOption:=xlSortTextAsNumbers
  End With
  With AnmerkTab.ListObjects("Anm").Sort
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
  ActiveSheet.ListObjects("Anm").Range.AutoFilter Field:=6, Criteria1:="N"

  With AnmerkTab
      Set rngZelle = .UsedRange.Find(Spaltenüberschrift, LookAt:=xlWhole)
      If Not rngZelle Is Nothing Then
          lngZeile = rngZelle.Row + 1
          Application.ScreenUpdating = False
          Do
              On Error Resume Next
              Set wshTabelle = Worksheets(CStr(.Cells(lngZeile, rngZelle.Column)))
              On Error GoTo 0
              If wshTabelle Is Nothing Then
                  Worksheets.Add After:=Worksheets(Worksheets.Count)
                  Set wshTabelle = Worksheets(Worksheets.Count)
                  wshTabelle.Name = .Cells(lngZeile, rngZelle.Column)
                  .Rows("1:" & rngZelle.Row).Copy wshTabelle.Range("A1")
                 
          ActiveSheet.DrawingObjects.Select   'Schaltflächen löschen
          Selection.Delete
         
          ActiveWindow.DisplayGridlines = False   'Gitternetzlinien ausblenden

              End If
              lngLetzte = IIf(IsEmpty(wshTabelle.Cells(wshTabelle.Rows.Count, rngZelle.Column)), _
                  wshTabelle.Cells(wshTabelle.Rows.Count, rngZelle.Column).End(xlUp).Row, _
                  wshTabelle.Rows.Count) + 1
              .Rows(lngZeile).Copy
              wshTabelle.Range("A" & lngLetzte).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      ActiveSheet.Paste
      Range("A1").Select
              lngZeile = lngZeile + 1
              Set wshTabelle = Nothing
          Loop While .Cells(lngZeile, rngZelle.Column) <> ""
          Set rngZelle = Nothing
         
     
          Application.CutCopyMode = False
          Application.ScreenUpdating = True
      End If
  End With
 
   With AnmerkTab.ListObjects("Anm")
      If .ShowAutoFilter Then
          If .AutoFilter.FilterMode Then
          .AutoFilter.ShowAllData
          End If
      End If
      .Sort.SortFields.Clear
      .Sort.SortFields.Add _
          Key:=Range("Anm[[#All],[lfd." & Chr(10) & "Nr.]]"), SortOn:=xlSortOnValues, Order:= _
          xlAscending, DataOption:=xlSortTextAsNumbers
  End With
 
  With AnmerkTab.ListObjects("Anm").Sort
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
 
  Application.Goto AnmerkTab.Range("A1")

 
End Sub

Danke!

[schauan]

Hallo Herbert,

im Prinzip wäre das eine Möglichkeit. Den Anfangvon Deinem Code hab ich mal weggelassen und wo ich hier die MsgBox hab kommt Deine Datenübertragung rein ...

Code:

…
ActiveSheet.ListObjects("Anm").Range.AutoFilter Field:=6, Criteria1:="N"
iCells=0
On Error Resume Next
iCells = ActiveSheet.ListObjects("Anm").DataBodyRange.SpecialCells(xlCellTypeVisible).Count
On Error GoTo 0
If iCells > 0 Then
    MsgBox "Alles ist gut" 'hier kommen Deine Aktionen
    '...
End If

   With AnmerkTab.ListObjects("Anm")
      If .ShowAutoFilter Then
          If .AutoFilter.FilterMode Then
          .AutoFilter.ShowAllData
          End If
      End If
      .Sort.SortFields.Clear
      .Sort.SortFields.Add _
          Key:=Range("Anm[[#All],[lfd." & Chr(10) & "Nr.]]"), SortOn:=xlSortOnValues, Order:= _
          xlAscending, DataOption:=xlSortTextAsNumbers
  End With
  
  With AnmerkTab.ListObjects("Anm").Sort
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
  
  Application.Goto AnmerkTab.Range("A1")

End Sub

[herbert0803]

Hallo Rene,

danke, aber das löst mein Problem nicht.
Damit wird abgefangen, dass eine Aufteilung stattfindet, wenn nach dem Filtern keine Zeilen sichtbar sind (kann ich auch verwenden), aber wenn nur einzelne Zeilen aufgrund vom Filter ausgeblendet sind, ändert sich nichts.
Ich glaube, dass Problem liegt in folgenden Bereichen.

Code:

   With AnmerkTab
       Set rngZelle = .UsedRange.Find(Spaltenüberschrift, LookAt:=xlWhole)
       If Not rngZelle Is Nothing Then
           lngZeile = rngZelle.Row + 1     'hier müsste nicht um eine Zeile weitergezählt werden, sondern bis zur nächsten sichtbaren

.
.
.
            lngZeile = lngZeile + 1 'hier wieder bis zur nächsten sichtbaren
            Set wshTabelle = Nothing
            Loop While .Cells(lngZeile, rngZelle.Column) <> ""

Es wird die Zeile mit der Spaltenüberschrift gesucht und dann ein Zeile darunter mit dem aufteilen begonnen.
Es sollte aber immer erst mit der nächsten sichtbaren Zeile begonnen werden.

[schauan]

Hallo Herbert,

Du hast aber von allen Zeilen geschrieben ...

Aber es wird auch ein neues Tabellenblatt erzeugt, für Werte wo alle Zeilen ausgeblendet sind. Wie kann ich das umgehen?

Ansonsten erst mal ein wackelrund:

lngZeile = rngZelle.Row + 1
Do While Rows(lngZeile).EntireRow.Hidden = True
lngZeile = rngZelle.Row + 1
Loop

[herbert0803]

Hallo Rene,

da habe ich mich falsch ausgedrückt.
Die Tabelle wird auf die verschiedenen Einträge in einer Spalte aufgeteilt.
Es kann sein, dass bei einem oder mehreren dieser verschiedenen Einträge alle aufgrund des Filters ausgeblendet sind, dann soll für diesen Eintrag kein Tabellenblatt erzeugt werden.
Schwer zum erklären, ich lade eine Beispieldatei hoch.
Hinweis: wenn der vollständige ausgeblendete Teil am Anfang der Tabelle steht habe ich etwas gefunden.

Code:

       Set rngZelle = .UsedRange.Find(Spaltenüberschrift, LookAt:=xlWhole)
       If Not rngZelle Is Nothing Then
           'lngZeile = rngZelle.Row + 1
           lngZeile = Range(rngZelle.Offset(1, 0), Cells(Rows.Count, rngZelle.Column)).SpecialCells(xlCellTypeVisible)(1).Row 'das funktioniert
           Application.ScreenUpdating = False

Aber bei den weiteren Einträgen funktioniert es dann nicht.

Code:

               'lngZeile = lngZeile + 1
               lngZeile = Range(Cells(lngZeile, rngZelle.Column).Offset(1, 0), Cells(Rows.Count, rngZelle.Column)).SpecialCells(xlCellTypeVisible)(1).Row 'das funktioniert nicht
               Set wshTabelle = Nothing
           Loop While .Cells(lngZeile, rngZelle.Column) <> ""

           Set rngZelle = Nothing

Deinen Vorschlag habe ich auch schon bei Suche gefunden, aber da scheint es so als ob er in eine endlos Schleife geht, jedenfalls bekomme ich von Excel keine Rückmeldung mehr und ich muss manuell unterbrechen.

Zur Beispielmappe:
mit dem Makro sollte jeweils nur ein Tabellenblatt für den Verantw. 2 (mit 2 Einträgen) und Verantw. 4 (mit 1 Eintrag) erzeugt werden.
Es wird aber auch ein Tabellenblatt für den Verantw. 3 erzeugt. Eintrag wird zwar keiner kopiert, aber es sollte erst gar kein neues Tabellenblatt für den Verantw. 3 erzeugt werden.