Herbers Excel/VBA-Archiv

VBA Erweiterter Filter Ausgabe anpassen

• VBA Erweiterter Filter Ausgabe anpassen von Thomas vom 21.01.2021 16:47:47
• AW: VBA Erweiterter Filter Ausgabe anpassen - von peterk am 21.01.2021 17:28:34
  • AW: VBA Erweiterter Filter Ausgabe anpassen - von Thomas am 21.01.2021 19:06:10
  • AW: VBA Erweiterter Filter Ausgabe anpassen - von Thomas am 22.01.2021 09:53:27

Betrifft: VBA Erweiterter Filter Ausgabe anpassen von: Thomas
Geschrieben am: 21.01.2021 16:47:47

Hallo liebe Forumsgemeinde,


ich habe folgendes Problem. Ich habe ein Workbook mit mehreren Sheets, welche im Aufbau nahezu identisch sind.

Sie beinhalten jeweils eine Tabelle mit gleichen Angaben außer in einer Spalte.


Nun möchte ich diese Sheets mit dem Advanced Filter durchsuchen und das Ergebnis auf einem separaten Sheet listen lassen.

Dies klappt mit meinem bisherigen Script auch einwandfrei.



Was ich jedoch jetzt noch haben möchte und wo ich nicht weiterkomme ist, daß das Makro mir alle Suchergebnisse unter den Headern wieder in eine Tabelle wandelt.

Ich habe die Suchausgabe von Sheet3 im Beispiel File mal in solch eine manuell geändert wie ich sie möchte für alle 3.


Das bisherige Script sieht so aus und funktioniert auch bis zum Punkt der Wandlung in eine Tabelle.


Vielleicht hat ja jemand eine Idee.



-----------------

Sub Macro1()
'
' Macro1 Macro
'
'
Dim lngLastRow As Long
Dim lngLastRowSC As Long

lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowSC = Sheets("Such").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Ziel").Select
Sheets("Ziel").Range("A1:E" & lngLastRow).Clear
    Sheets("Sheet3").Range("Table1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A1"), _
        Unique:=False
        
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
     Sheets("Sheet4").Range("Table2[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A" & lngLastRow + 1),  _
 _
_
        Unique:=False
        
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("Sheet5").Range("Table3[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A" & lngLastRow + 1),  _
 _
_
        Unique:=False  

End Sub

https://www.herber.de/bbs/user/143202.zip

  

Betrifft: AW: VBA Erweiterter Filter Ausgabe anpassen
von: peterk
Geschrieben am: 21.01.2021 17:28:34

Hallo

Sub Macro1()

    Dim lngLastRow As Long
    Dim lngLastRowSC As Long
    Dim myRange(3) As String
    
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
    lngLastRowSC = Sheets("Such").Cells(Rows.Count, 1).End(xlUp).Row

    Sheets("Ziel").Select

    Sheets("Ziel").Range("A1:E" & lngLastRow).Clear

    Sheets("Sheet3").Range("Table1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A1"), _
        Unique:=False

    myRange(1) = "A1:E"
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
    myRange(1) = myRange(1) & lngLastRow
    
    Sheets("Sheet4").Range("Table2[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A" & lngLastRow + 1),  _
_
        Unique:=False
        
    myRange(2) = "A" & lngLastRow + 1 & ":E"
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
    myRange(2) = myRange(2) & lngLastRow
        
    Sheets("Sheet5").Range("Table3[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Such").Range("A1:C2"), CopyToRange:=Range("A" & lngLastRow + 1),  _
_
        Unique:=False
        
    myRange(3) = "A" & lngLastRow + 1 & ":E"
    lngLastRow = Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row
    myRange(3) = myRange(3) & lngLastRow
    
    Sheets("Ziel").ListObjects.Add(xlSrcRange, Range(myRange(1)), , xlYes).Name = _
        "Sheet4"
    Sheets("Ziel").ListObjects.Add(xlSrcRange, Range(myRange(2)), , xlYes).Name = _
        "Sheet3"
    Sheets("Ziel").ListObjects.Add(xlSrcRange, Range(myRange(3)), , xlYes).Name = _
        "Sheet5"
           
End Sub

  

Betrifft: AW: VBA Erweiterter Filter Ausgabe anpassen
von: Thomas
Geschrieben am: 21.01.2021 19:06:10

MEGA DANKE SCHÖN!!!!! Hat funktioniert

  

Betrifft: AW: VBA Erweiterter Filter Ausgabe anpassen
von: Thomas
Geschrieben am: 22.01.2021 09:53:27

Hallo Peter,

ich habe jetzt doch noch ein Problem entdeckt. Wenn kein Wert entsprechend der Suchkriterien gefunden wird, bekomm ich einen Runtime Error.

Getestet habe ich das, weil ich noch versuche, dass wenn kein Wert in der durchsuchten Tabelle ist, diese zu überspringen und garnicht erst ins Ziel zu kopieren. Wenn ich um das Reinkopieren nicht komme ist das kein Problem, aber der Runtime Error macht mir sorgen...

Hoffe du liest das, besten Dank für dein Hilfe