Hallo,
ich habe es geschafft :)
Hier da Ergebnis. Die Schleife am Ende um alle Filter zu löschen habe ich aus dem Netz.
Code:
Sub Char_einlesen()
'
' Char_einlesen Makro
'
' Tastenkombination: Strg+Umschalt+C
'
Dim filter_daten(6) As String
Dim Zeile As Integer
Dim Spalte As Integer
Dim x As Integer
Dim intI As Integer
Dim loLetzte As Long
Zeile = 2
Spalte = 3
x = 0
loLetzte = 0
While Zeile <= 2
While Spalte <= 9
filter_daten(x) = Worksheets("Tabelle1").Cells(Zeile, Spalte).Value
Spalte = Spalte + 1
x = x + 1
Wend
If filter_daten(0) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=3, Criteria1:=filter_daten(0)
End If
If filter_daten(1) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=6, Criteria1:=filter_daten(1)
End If
If filter_daten(2) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=17, Criteria1:=filter_daten(2)
End If
If filter_daten(3) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=7, Criteria1:=filter_daten(3)
End If
If filter_daten(5) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=21, Criteria1:=filter_daten(5)
End If
If filter_daten(6) <> "" Then
Worksheets("Tabelle2").Range("A2:X2").AutoFilter Field:=24, Criteria1:=filter_daten(6)
End If
With Worksheets("Tabelle3")
loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
Worksheets("Tabelle2").Range("E2:E" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy Worksheets("Tabelle3").Cells(loLetzte, 2)
With Worksheets("Tabelle2")
If .AutoFilterMode Then
For Each af In .AutoFilter.Filters
If af.On Then
.ShowAllData
Exit For
End If
Next
End If
End With
Zeile = Zeile + 1
Spalte = 3
x = 0
Wend
End Sub
Danke dass ihr euch die Zeit genommen habt!
Sehr nettes Forum hier!
(12.11.2017, 20:13)Loeffelblock schrieb: [ -> ]Folgende Probleme habe ich noch:
1.Es sollen die Filter nur gesetzt werden, wenn in der Zelle etwas steht. Wenn nichts drin ist, soll das nicht passieren.
Das würde ich mit einer if Anweisung realisieren, weiß aber nicht was dann als Bedingung da stehen muss.
2. Nach dem Filtern sollen die Werte aus Spalte E kopiert werden und dann im anderen Tabellenblatt eingefügt werden.
Da das komplette Makro über eine Schleife mehrmals Zeile für Zeile Filtern, kopieren, einfügen soll, habe ich das Problem, dass das Einfügen jedes mal unter dem schon eingefügten eingesetzt werden soll.
Sub FilternTab2NachTab3()
Dim varFilter As Variant
varFilter = Worksheets("Tabelle1").Range("C2:H2").Value
With Worksheets("Tabelle2").Range("A2:W2")
If .Parent.FilterMode Then .Parent.ShowAllData
If varFilter(1, 1) <> "" Then .AutoFilter Field:=3, Criteria1:=varFilter(1, 1)
If varFilter(1, 2) <> "" Then .AutoFilter Field:=6, Criteria1:=varFilter(1, 2)
If varFilter(1, 3) <> "" Then .AutoFilter Field:=17, Criteria1:=varFilter(1, 3)
If varFilter(1, 4) <> "" Then .AutoFilter Field:=7, Criteria1:=varFilter(1, 4)
If varFilter(1, 5) <> "" Then .AutoFilter Field:=21, Criteria1:=varFilter(1, 5)
If varFilter(1, 6) <> "" Then .AutoFilter Field:=23, Criteria1:=varFilter(1, 6)
With .Parent.AutoFilter.Range.Columns(5)
.Offset(1).Resize(.Cells.Count - 1).SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Tabelle3").Cells(Rows.Count, 2).End(xlUp).Offset(1)
End With
If .Parent.FilterMode Then .Parent.ShowAllData
End With
End Sub
Gruß Uwe
Hallo,
hab da noch was zu verbessern. Brauche noch eine Abbruchbedingung für eine Zeile falls beim Filtern kein Ergebnis kommt.
Was schreibe ich hier in die if -Anweisung (erste Zeile)? :)
Code:
If Worksheets("Tabelle2").Range("E2:E" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy = True Then
With Worksheets("Tabelle3")
loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
Worksheets("Tabelle2").Range("E2:E" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy Worksheets("Tabelle3").Cells(loLetzte, 2)
End If
Ich habs mal probiert, aber das will nicht funktionieren :)
Freundliche Grüße
Hallöchen,
was zu kopieren ist ja nicht unbedingt als Bedingung verwendbar
Du könntest vorher mit Teilergebnis prüfen. und wenn da mehr als 0 rauskommt, wird was gefunden. Im Prinzip
If Application.WorksheetFunction.Subtotal(2, Range("E2:E3")) > 0 then
...
Hallo,
(13.11.2017, 21:48)Loeffelblock schrieb: [ -> ]Brauche noch eine Abbruchbedingung für eine Zeile falls beim Filtern kein Ergebnis kommt.
vielleicht auch so:
Sub FilternTab2NachTab3()
Dim varFilter As Variant
varFilter = Worksheets("Tabelle1").Range("C2:H2").Value
With Worksheets("Tabelle2").Range("A2:W2")
If .Parent.FilterMode Then .Parent.ShowAllData
If varFilter(1, 1) <> "" Then .AutoFilter Field:=3, Criteria1:=varFilter(1, 1)
If varFilter(1, 2) <> "" Then .AutoFilter Field:=6, Criteria1:=varFilter(1, 2)
If varFilter(1, 3) <> "" Then .AutoFilter Field:=17, Criteria1:=varFilter(1, 3)
If varFilter(1, 4) <> "" Then .AutoFilter Field:=7, Criteria1:=varFilter(1, 4)
If varFilter(1, 5) <> "" Then .AutoFilter Field:=21, Criteria1:=varFilter(1, 5)
If varFilter(1, 6) <> "" Then .AutoFilter Field:=23, Criteria1:=varFilter(1, 6)
With .Parent.AutoFilter.Range.Columns(5)
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
.Offset(1).Resize(.Cells.Count - 1).SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Tabelle3").Cells(Rows.Count, 2).End(xlUp).Offset(1)
End If
End With
If .Parent.FilterMode Then .Parent.ShowAllData
End With
End Sub
Gruß Uwe