VBA Daten in Reiter

[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

[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

Was genau habe ich kaputt gemacht? 

Beste Grüße
Leo

---

Anbei nochmal eine Testdatei

[00202]

Hallo Leonhard, :19:

schau dir die Unterschiede an: :21:
[attachment=30719]

[Leonhard]

Hallo Case,

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..

Beste Grüße
Leo

[00202]

Hallo Leo, :19:

an der Stelle: :21:

Code:

'.........
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
'.........

[Leonhard]

Hallo zusammen,

ich muss das Thema doch nochmal aufmachen.
Ich scheitere daran wenn das Kriterium nachdem aufgeteilt werden soll in Spalte A steht:

Code:

' Variablendeklaration erfordelich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main

'--------------------------------------------------------------------------
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

Leo