Makro Hilfe benötigt!

[Loeffelblock]

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!

[Kuwer]

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

[Loeffelblock]

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

[schauan]

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

[Kuwer]

Hallo,

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