Liste filtern mit Hilfe von Makro

Guten Morgen,
Ich hoffe jemand kann mir mit der folgenden Frage helfen:
Ich muss 100 mal am Tag eine Excel Liste/Tabelle nach verschiedene Kriterien filtern und basierend darauf fuer jeden einzelnen Fall eine Entscheidung treffen. Da dies viel Zeit nimmt habe ich mich gewundert ob es nicht mit der Hilfe einer oder zwei Makros schneller gemacht werden koennte.
Die Liste hat einen Auto Filter in der Reihe 4.
Was ich brauche ist ein Makro das beim Starten zwei prompts zeigt fuer dennen Werte eingegeben muessen wie folgt:
Makro Starten
1) Prompt/Eingabekaestchen: Geben Sie Wert fuer filter in Spalte 5 (Zelle E4): z.B 60
2) Prompt/Eingabekaestchen: Geben Sie Wert fuer filter in Spalte 8 (Zelle H4): z.B 4.00
3) Dann soll die Spalte 5 so gefiltert werden dass in dem Beispiel oben alle Werte 60+-2 gezeigt werden: also 58,59,60,61,62 oder >57; 4) Aehnlich mit der Spalte 8, aber hier alle Werte 4+- 0.10, also 3,90;3,91;3,92;3,93 . 3,99; 4,00; 4,01; 4,02 . 4,09; 4,10 oder >3,89 ; Es kann sein dass es fuer einige davon keine Werde vorhanden sind. Diese sollte das Makro ignorieren.
Dann braeuchte ich ein zweites Makro dass alle Filterkriterien loescht. Ich bin nicht sicher ob es eine solche Funktion in Excel schon gibt, dann wuerde ich natuerlich das Makro nicht brauchen.
Hoffe ich habe es mehr oder weniger gut erklaert und dass jemand mir damit helfen kann
Vielen Dank im Voraus
Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub FilterSetzen() Dim Wert1, Wert2 'Abfrage Werte Wert1 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 5 (Zelle E4):", Type:=1) Wert2 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 8 (Zelle H4):", Type:=1) If Not IsNumeric(Wert1) And Not IsNumeric(Wert2) Then Exit Sub Application.ScreenUpdating = False 'Benutzter Bereich With ActiveSheet.Range("A4:H" & Rows.Count) 'Wert1 filtern If IsNumeric(Wert1) Then .AutoFilter Field:=5, Criteria1:=">=" & Wert1 - 4, _ Operator:=xlAnd, Criteria2:="<=" & Wert1 + 4 End If 'Wert2 filtern If IsNumeric(Wert2) Then .AutoFilter Field:=8, Criteria1:=">=" & Wert1 - 0.1, _ Operator:=xlAnd, Criteria2:="<=" & Wert2 + 0.1 If .SpecialCells(xlCellTypeVisible).Rows.Count < 5 Then .AutoFilter Field:=8 End If End If End With Application.ScreenUpdating = True End Sub Sub Filter_Loeschen() If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If End Sub

Sub FilterSetzen() Dim Wert1, Wert2 'Abfrage Werte Wert1 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 4 (Zelle D4):", Type:=1) Wert2 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 7 (Zelle G4):", Type:=1) If Not IsNumeric(Wert1) And Not IsNumeric(Wert2) Then Exit Sub Application.ScreenUpdating = False 'Benutzter Bereich With ActiveSheet.Range("A4:W" & Rows.Count) 'Wert1 filtern If IsNumeric(Wert1) Then .AutoFilter Field:=4, Criteria1:=">=" & Wert1 - 2, _ Operator:=xlAnd, Criteria2:="<=" & Wert1 + 2 End If 'Wert2 filtern If IsNumeric(Wert2) Then .AutoFilter Field:=7, Criteria1:=">=" & Wert2 - 0.1, _ Operator:=xlAnd, Criteria2:="<=" & Wert2 + 0.1 If .SpecialCells(xlCellTypeVisible).Rows.Count < 5 Then .AutoFilter Field:=7 End If End If End With Application.ScreenUpdating = True End Sub

Sub FilterSetzen() Dim Wert1, Wert2, MaxWert, MinWert 'Abfrage Werte Wert1 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 4 (Zelle D4):", Type:=1) Wert2 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 7 (Zelle G4):", Type:=1) If Not IsNumeric(Wert1) And Not IsNumeric(Wert2) Then Exit Sub Application.ScreenUpdating = False 'Benutzter Bereich With ActiveSheet.Range("A4:W" & Rows.Count) 'Wert1 filtern If IsNumeric(Wert1) Then MinWert = Replace(CStr(Wert1 - 2), ",", ".") MaxWert = Replace(CStr(Wert1 + 2), ",", ".") .AutoFilter Field:=4, Criteria1:=">=" & MinWert, _ Operator:=xlAnd, Criteria2:="<=" & MaxWert End If 'Wert2 filtern If IsNumeric(Wert2) Then MinWert = Replace(CStr(Wert2 - 0.1), ",", ".") MaxWert = Replace(CStr(Wert2 + 0.1), ",", ".") .AutoFilter Field:=7, Criteria1:=">=" & MinWert, _ Operator:=xlAnd, Criteria2:="<=" & MaxWert If ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row < 5 Then .AutoFilter Field:=7 End If End If End With Application.ScreenUpdating = True End Sub

Dim Wert1$, Wert2$, MaxWert, MinWert 'Abfrage Werte Wert1 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 4 (Zelle D4):") Wert2 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 7 (Zelle G4):") '...

Hallo,
eine Optimierung auf Deine Bedürfnisse wo die Eingabe egal ist müsste so gehen.
Allerdings wird nun auch gefiltert, wenn nur eine Eingabe abgebrochen wird. (sonst wie alter Code)

Sub FilterSetzen()
Dim Wert1$, Wert2$, MaxWert, MinWert
Dim KommaOrPunkt$

'Abfrage Werte 
Wert1 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 4 (Zelle D4):")
Wert2 = Application.InputBox("Geben Sie Wert fuer filter in Spalte 7 (Zelle G4):")

Application.ScreenUpdating = False

'Benutzter Bereich 
With ActiveSheet.Range("A4:W" & Rows.Count)
    KommaOrPunkt$ = IIf("0.5" * 2 = 1, ".", ",")
    
    'Wert1 filtern 
    If IsNumeric(Wert1) Then
        Wert1 = Replace(Wert1, ",", KommaOrPunkt$)
        Wert1 = Replace(Wert1, ".", KommaOrPunkt$)
        MinWert = Replace(CStr(Wert1 - 2), ",", ".")
        MaxWert = Replace(CStr(Wert1 + 2), ",", ".")
        .AutoFilter Field:=4, Criteria1:=">=" & MinWert, _
            Operator:=xlAnd, Criteria2:="<=" & MaxWert
    End If
    
    'Wert2 filtern 
    If IsNumeric(Wert2) Then
        Wert2 = Replace(Wert2, ",", KommaOrPunkt$)
        Wert2 = Replace(Wert2, ".", KommaOrPunkt$)
        MinWert = Replace(CStr(Wert2 - 0.1), ",", ".")
        MaxWert = Replace(CStr(Wert2 + 0.1), ",", ".")
        .AutoFilter Field:=7, Criteria1:=">=" & MinWert, _
            Operator:=xlAnd, Criteria2:="<=" & MaxWert
        
        If ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row < 5 Then
            .AutoFilter Field:=7
        End If
    End If

End With
Application.ScreenUpdating = True

End Sub

Gruß Tino

Sub FilterSetzen() Dim MaxWert$, MinWert$ If Not IsNumeric(Range("K1")) And Not IsNumeric(Range("O1")) Then MsgBox "keine Zahl in K1 oder O1", vbExclamation Exit Sub End If Application.ScreenUpdating = False 'Benutzter Bereich With ActiveSheet.Range("A4:W" & Rows.Count) 'Wert1 filtern If IsNumeric(Range("K1")) Then MinWert = Replace(CStr(Range("K1") - 2), ",", ".") MaxWert = Replace(CStr(Range("K1") + 2), ",", ".") .AutoFilter Field:=4, Criteria1:=">=" & MinWert, _ Operator:=xlAnd, Criteria2:="<=" & MaxWert End If 'Wert2 filtern If IsNumeric(Range("O1")) Then MinWert = Replace(CStr(Range("O1") - 0.1), ",", ".") MaxWert = Replace(CStr(Range("O1") + 0.1), ",", ".") .AutoFilter Field:=7, Criteria1:=">=" & MinWert, _ Operator:=xlAnd, Criteria2:="<=" & MaxWert If ActiveSheet.Cells(ActiveSheet.Rows.Count, 7).End(xlUp).Row < .Cells(2, 1).Row Then .AutoFilter Field:=7 End If End If End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Liste filtern mit Hilfe von Makro

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste filtern mit Hilfe von Makro

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread