29.03.2020, 12:44 (Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2020, 12:45 von snb.)
So geht das:
Code:
Sub M_snb()
With Sheet1
.Columns(4).AdvancedFilter 2, , .Cells(1, 40), True
.Columns(40).Sort .Cells(1, 40), 2, , , , , , True
sn = .Cells(1, 40).CurrentRegion
.Cells(1, 40).CurrentRegion.Offset(2).ClearContents
With .Cells(1).CurrentRegion
For j = 2 To UBound(sn)
Sheet1.Cells(2, 40) = sn(j, 1)
Sheets.Add(, Sheets(Sheets.Count)).Name = sn(j, 1)
.AdvancedFilter 2, Sheet1.Cells(1, 40).CurrentRegion, Sheets(sn(j,1)).Cells(1)
Next
End With
End with
End Sub
29.03.2020, 16:14 (Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2020, 16:15 von Leonhard.)
Servus Case,
ich hoffe zum letzte Mal zu nerven...
Ich habe den Code für eine andere Datei übernehmen wollen. Hier sind die Überschriften in A5 und die Daten fangen in A6 an.
Also habe ich immer A1 mit A5 und A2 mit A6 getauscht..
und in dem Bereich die "1: " ... durch eine 5 ersetzt
Code:
' Kopiere mit dem Spezialfilter die Liste OHNE Mehrfache (Unique=True)
SourceSheet.Range(strQuellColumn & "5:" & strQuellColumn & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=CriteriaSheet.Range("A5"), Unique:=True
Code:
Public Sub Main()
' Variablendeklaration
Dim CriteriaSheet As Worksheet
Dim SourceSheet As Worksheet
Dim strQuellColumn As String
Dim strBisColumn As String
Dim rngCriterion As Range
Dim vntReturn As Variant
Dim wksNew As Worksheet
Dim wksTMP As Worksheet
Dim wkbBook As Workbook
Dim lngLastRow As Long
Dim lngReturn As Long
Dim lngCalc As Long
' Welche Spalte beinhaltet das Kriterium bzw. nach welcher Spalte soll aufgeteilt werden
strQuellColumn = "D"
' Der Bereich der kopiert werden soll bzw. wie weit geht meine Tabelle - hier bis Spalte Q
strBisColumn = "DA"
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
ChDir ThisWorkbook.Path
' Dateiauswahldialog mit Filter auf XLSX, XLSM, XLSB und Alle _MEHRFACHAUSWAHL möglich
vntReturn = Application.GetOpenFilename(FileFilter:="XLSX-Format (*.xlsx), " & _
"*.xlsx, XLSM-Format (*.xlsm), *.xlsm, XLSB-Format (*.xlsb), *.xlsb, Alle (*.*), *.*", MultiSelect:=True)
' Wenn NICHT auf Abbrechen geklickt wurde dann - ist es ein Array...
If IsArray(vntReturn) Then
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
With Application
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating = False
' Ereignisroutinen werden deaktiviert
.EnableEvents = False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc = .Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation = xlCalculationManual
' Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts = False
End With
For lngReturn = LBound(vntReturn) To UBound(vntReturn)
' Öffne die ausgewählte Datei OHNE die Links zu aktualisieren UND Schreibgeschützt
Set wkbBook = Workbooks.Open(vntReturn(lngReturn), 0, True)
' Schleife über jeder Tabellenblatt in der eben geöffneten Datei
For Each wksTMP In wkbBook.Worksheets
' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
If wksTMP.Index > 1 Then
' ... lösche es
wksTMP.Delete
End If
Next wksTMP
' Tabellenblatt mit den Grunddaten - hier das erste Tabellenblatt.
' Alle anderen sind ja gelöscht!
Set SourceSheet = wkbBook.Worksheets(1)
' Ein Kriterientabellenblatt wird hinzugefügt
Set CriteriaSheet = wkbBook.Worksheets.Add
' Und an das Ende verschoben
CriteriaSheet.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
' Ermittelt die letzte belegte Zeile im Quelltabellenblatt Splate D
lngLastRow = SourceSheet.Range(strQuellColumn & Rows.Count).End(xlUp).Row
' Kopiere mit dem Spezialfilter die Liste OHNE Mehrfache (Unique=True)
SourceSheet.Range(strQuellColumn & "5:" & strQuellColumn & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=CriteriaSheet.Range("A5"), Unique:=True
' Leerzeilen löschen
CriteriaSheet.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Das erste Kriterium zuweisen
Set rngCriterion = CriteriaSheet.Range("A6")
' So lange schleifen, bis kein Kriterium mehr vorhanden ist
While rngCriterion.Value <> ""
' Neues Tabellenblatt
Set wksNew = wkbBook.Worksheets.Add
' Ans Ende stellen
wksNew.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
' Über Spezialfilter alle passenden Kriterienzeilen (von A bis Q) kopieren
SourceSheet.Range("A5:" & strBisColumn & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriterion.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A5")
' Tabellenblatt mit Kriterium benennen
wksNew.Name = rngCriterion.Value
' Das erledigte Kriterium löschen
rngCriterion.EntireRow.Delete
' Setze die Objektvariablen auf Nothing
Set rngCriterion = Nothing
Set wksNew = Nothing
' Das nächste Kriterium zuweisen
Set rngCriterion = CriteriaSheet.Range("A6")
' Und weiter im Text...
Wend
' Wenn ein Kriterientabellenblatt vorhanden ist, lösche es
If Not CriteriaSheet Is Nothing Then CriteriaSheet.Delete
' Gehe zum Quelltabellenblatt nach A1
Application.Goto SourceSheet.Range("A5"), True
' SpeichernUnter-Dialog aufrufen. Name mit Datum und Zeit vorangestellt vorgeben
Application.Dialogs(xlDialogSaveAs).Show ThisWorkbook.Path & "\" & Format(Now, "ddMMyyyy_hhmmss_") & wkbBook.Name
' Wenn die Quelldatei noch offen ist - dann schließen OHNE speichern
If Not wkbBook Is Nothing Then wkbBook.Close False
Next lngReturn
End If
Fin:
' Die Applikation aufwecken
With Application
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating = True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents = True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation = lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts = True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode = True
End With
' Setze die Objektvariablen auf Nothing
Set wkbBook = Nothing
Set CriteriaSheet = Nothing
Set SourceSheet = Nothing
Set rngCriterion = Nothing
Set wksNew = Nothing
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
doch noch eine Frage
wie kann ich sicher stellen bzw. wo bringe ich im Code noch unter dass alle gesetzten Filter im Vorfeld gelöscht werden?
Sheets("wbkbook.Worksheets(1)").ShowAllData habe versucht das im Code unter zu bringen aber scheitere kläglich
Die Dateien die ich bekomme sind leider teilweise noch mit Filtern und dann wird dementsprechend auch nicht der gesamte Datenstamm durch das aktuelle Makro in die einzelnen Reiter extrahiert..
'.........
Set SourceSheet = wkbBook.Worksheets(1)
With SourceSheet
' Ist da überhaupt ein Filter?
If .AutoFilterMode Then
' Filter gesetzt?
If .FilterMode Then
.ShowAllData
End If
End If
End With
' Ein Kriterientabellenblatt wird hinzugefügt
Set CriteriaSheet = wkbBook.Worksheets.Add
'.........
________ Servus
Case
Folgende(r) 1 Nutzer sagt Danke an Case für diesen Beitrag:1 Nutzer sagt Danke an Case für diesen Beitrag 28 • Leonhard
'--------------------------------------------------------------------------
Public Sub Main()
' Variablendeklaration
Dim CriteriaSheet As Worksheet
Dim SourceSheet As Worksheet
Dim strQuellColumn As String
Dim strBisColumn As String
Dim rngCriterion As Range
Dim vntReturn As Variant
Dim wksNew As Worksheet
Dim wksTMP As Worksheet
Dim wkbBook As Workbook
Dim lngLastRow As Long
Dim lngReturn As Long
Dim lngCalc As Long
' Welche Spalte beinhaltet das Kriterium bzw. nach welcher Spalte soll aufgeteilt werden
strQuellColumn = "A"
' Der Bereich der kopiert werden soll bzw. wie weit geht meine Tabelle - hier bis Spalte Q
strBisColumn = "V"
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
ChDir ThisWorkbook.Path
' Dateiauswahldialog mit Filter auf XLSX, XLSM, XLSB und Alle _MEHRFACHAUSWAHL möglich
vntReturn = Application.GetOpenFilename(FileFilter:="XLSX-Format (*.xlsx), " & _
"*.xlsx, XLSM-Format (*.xlsm), *.xlsm, XLSB-Format (*.xlsb), *.xlsb, Alle (*.*), *.*", MultiSelect:=True)
' Wenn NICHT auf Abbrechen geklickt wurde dann - ist es ein Array...
If IsArray(vntReturn) Then
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
With Application
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating = False
' Ereignisroutinen werden deaktiviert
.EnableEvents = False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc = .Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation = xlCalculationManual
' Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts = False
End With
For lngReturn = LBound(vntReturn) To UBound(vntReturn)
' Öffne die ausgewählte Datei OHNE die Links zu aktualisieren UND Schreibgeschützt
Set wkbBook = Workbooks.Open(vntReturn(lngReturn), 0, True)
' Schleife über jeder Tabellenblatt in der eben geöffneten Datei
For Each wksTMP In wkbBook.Worksheets
' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
If wksTMP.Index > 1 Then
' ... lösche es
wksTMP.Delete
End If
Next wksTMP
' Tabellenblatt mit den Grunddaten - hier das erste Tabellenblatt.
' Alle anderen sind ja gelöscht!
Set SourceSheet = wkbBook.Worksheets(1)
With SourceSheet
' Ist da überhaupt ein Filter?
If .AutoFilterMode Then
' Filter gesetzt?
If .FilterMode Then
.ShowAllData
End If
End If
End With
' Ein Kriterientabellenblatt wird hinzugefügt
Set CriteriaSheet = wkbBook.Worksheets.Add
' Und an das Ende verschoben
CriteriaSheet.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
' Ermittelt die letzte belegte Zeile im Quelltabellenblatt Splate D
lngLastRow = SourceSheet.Range(strQuellColumn & Rows.Count).End(xlUp).Row
' Kopiere mit dem Spezialfilter die Liste OHNE Mehrfache (Unique=True)
SourceSheet.Range(strQuellColumn & "4:" & strQuellColumn & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=CriteriaSheet.Range("A1"), Unique:=True
' Leerzeilen löschen
CriteriaSheet.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Das erste Kriterium zuweisen
Set rngCriterion = CriteriaSheet.Range("A2")
' So lange schleifen, bis kein Kriterium mehr vorhanden ist
While rngCriterion.Value <> ""
' Neues Tabellenblatt
Set wksNew = wkbBook.Worksheets.Add
' Ans Ende stellen
wksNew.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
' Über Spezialfilter alle passenden Kriterienzeilen (von A bis Q) kopieren
SourceSheet.Range("A4:" & strBisColumn & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriterion.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1")
' Tabellenblatt mit Kriterium benennen
wksNew.Name = rngCriterion.Value
' Das erledigte Kriterium löschen
rngCriterion.EntireRow.Delete
' Setze die Objektvariablen auf Nothing
Set rngCriterion = Nothing
Set wksNew = Nothing
' Das nächste Kriterium zuweisen
Set rngCriterion = CriteriaSheet.Range("A2")
' Und weiter im Text...
Wend
' Wenn ein Kriterientabellenblatt vorhanden ist, lösche es
If Not CriteriaSheet Is Nothing Then CriteriaSheet.Delete
' Gehe zum Quelltabellenblatt nach A1
Application.Goto SourceSheet.Range("A1"), True
' SpeichernUnter-Dialog aufrufen. Name mit Datum und Zeit vorangestellt vorgeben
Application.Dialogs(xlDialogSaveAs).Show ThisWorkbook.Path & "\" & Format(Now, "ddMMyyyy_hhmmss_") & wkbBook.Name
' Wenn die Quelldatei noch offen ist - dann schließen OHNE speichern
If Not wkbBook Is Nothing Then wkbBook.Close False
Next lngReturn
End If
Fin:
' Die Applikation aufwecken
With Application
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating = True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents = True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation = lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts = True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode = True
End With
' Setze die Objektvariablen auf Nothing
Set wkbBook = Nothing
Set CriteriaSheet = Nothing
Set SourceSheet = Nothing
Set rngCriterion = Nothing
Set wksNew = Nothing
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Kann jemand direkt erkennen was ich falsch gemacht habe?
Beste Grüße