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")
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
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.
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
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 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...
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
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")
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
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
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
14.06.2019, 07:15 (Dieser Beitrag wurde zuletzt bearbeitet: 14.06.2019, 08:05 von 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.
17.06.2019, 07:33 (Dieser Beitrag wurde zuletzt bearbeitet: 17.06.2019, 07:35 von 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.
