AW: Kriterium Autofilter variabel auslesen & einsetzen
24.11.2008 15:53:45
fcs
Hallo Bjoern,
Hier mal ein paar Varianten, wobei man meiner Meinung nach das Ganze auch ohne Autofilter lösen kann, nämlich mit der Suchen-Methode.
Die kriterien trägst du für meine Vorschläge im Blatt "Nein" in Spalte A ab Zeile 1 ein.
Ob du die Variante mit den Arrays benötigst, hängt davon ab, ob du die Nummern der gefundenen Zeilen noch irgendwie weiterverarbeiten muss.
Gruß
Franz
Sub NeinKriterien()
'Kriterien Filtern und speichern der geänderten Zeilen in einem Array. _
Anzeige der Kriterien und zeilen in einer MsgBox.
Dim wksNein As Worksheet, lngNein As Long, varKriterium As Variant
Dim wksDetail As Worksheet, lngDetail As Long
Dim intKrit, arrKriterium() As String, arrRow63tub() As Long, arrRowT63tub() As Long
Dim x As Long, strMsg As String
Set wksNein = Worksheets("Nein")
Set wksDetail = Worksheets("Details")
wksDetail.Activate
With wksNein
'Zeilen mit Kriterien im Blatt "nein" abarbeiten
For lngNein = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
varKriterium = .Cells(lngNein, 1).Value
intKrit = intKrit + 1
ReDim Preserve arrKriterium(1 To intKrit)
arrKriterium(intKrit) = varKriterium
ReDim Preserve arrRow63tub(1 To intKrit)
ReDim Preserve arrRowT63tub(1 To intKrit)
Selection.AutoFilter Field:=1, Criteria1:=varKriterium
Range("A1").Select
'Abfrage, wieviele Datensätze im Autofilter stehen
'Anzahl aller angezeigten Zeilen im Autofilter einschließlich Kopfzeile
x = Application.WorksheetFunction.Subtotal(3, ActiveSheet.AutoFilter.Range.Columns(1))
If x > 1 Then 'mindestens eine Datenzeile wird angezeigt
arrRow63tub(intKrit) = 3 'Nummer der Zeile unter Autofilter-Titelzeile
Do Until IsEmpty(Cells(arrRow63tub(intKrit), 1))
If Rows(arrRow63tub(intKrit)).Hidden = False Then
arrRowT63tub(intKrit) = arrRow63tub(intKrit)
Exit Do
End If
arrRow63tub(intKrit) = arrRow63tub(intKrit) + 1
Loop
If arrRowT63tub(intKrit) > 0 Then
Cells(arrRowT63tub(intKrit), 8).Value = "nein" 'Spalte H
End If
End If
Selection.AutoFilter Field:=1
Next
End With
'Änderungen in MsgBox anzeigen
strMsg = "Kriterium - Zeile"
For lngNein = 1 To intKrit
strMsg = strMsg & vbLf & arrKriterium(lngNein) & " - " & arrRowT63tub(lngNein)
If lngNein Mod 20 = 0 Then
MsgBox strMsg
strMsg = "Kriterium - Zeile"
End If
Next
If strMsg "Kriterium - Zeile" Then
MsgBox strMsg, vbOKOnly, "Kriterien mit Nein"
End If
End Sub
Sub NeinKriterien_ohneFelder()
'Kriterien Filtern und markieren ohne Speichern der geänderten Zeilen
Dim wksNein As Worksheet, lngNein As Long, varKriterium As Variant
Dim wksDetail As Worksheet, lngDetail As Long
Dim arrRow63tub As Long, arrRowT63tub As Long
Dim x As Long
Set wksNein = Worksheets("Nein")
Set wksDetail = Worksheets("Details")
wksDetail.Activate
Application.ScreenUpdating = False
With wksNein
'Zeilen mit Kriterien im Blatt "nein" abarbeiten
For lngNein = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
varKriterium = .Cells(lngNein, 1).Value
arrRowT63tub = 0 'Trefferzeile zurücksetzen
Selection.AutoFilter Field:=1, Criteria1:=varKriterium
Range("A1").Select
'Abfrage, wieviele Datensätze im Autofilter stehen
'Anzahl aller angezeigten Zeilen im Autofilter einschließlich Kopfzeile
x = Application.WorksheetFunction.Subtotal(3, ActiveSheet.AutoFilter.Range.Columns(1))
If x > 1 Then 'mindestens eine Datenzeile wird angezeigt
arrRow63tub = 3 'Nummer der Zeile unter Autofilter-Titelzeile
Do Until IsEmpty(Cells(arrRow63tub, 1))
If Rows(arrRow63tub).Hidden = False Then
arrRowT63tub = arrRow63tub
Exit Do
End If
arrRow63tub = arrRow63tub + 1
Loop
If arrRowT63tub > 0 Then
Cells(arrRowT63tub, 8).Value = "nein" 'Spalte H
End If
End If
Selection.AutoFilter Field:=1
Next
End With
Application.ScreenUpdating = True
End Sub
Sub NeinKriterien_Suchen()
'Nein-Kriterien markieren ohne Autofilter setzen.
'Jeweils die alle Fundstellen in Spalte 1 werden auf "nein" gesetzt
Dim wksNein As Worksheet, lngNein As Long, varKriterium As Variant
Dim wksDetail As Worksheet, rngGefunden As Range, strAdresse
Set wksNein = Worksheets("Nein")
Set wksDetail = Worksheets("Details")
wksDetail.Activate
Application.ScreenUpdating = False
With wksNein
'Zeilen mit Kriterien im Blatt "nein" abarbeiten
For lngNein = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
varKriterium = .Cells(lngNein, 1).Value
With wksDetail
Set rngGefunden = .Columns(1).Find(What:=varKriterium, LookIn:=xlValues, _
lookat:=xlWhole)
If rngGefunden Is Nothing Then
MsgBox varKriterium & " nicht im Blatt Details Spalte 1 gefunden!"
Else
strAdresse = rngGefunden.Address ' 1. Fundstelle merken
Do
.Cells(rngGefunden.Row, 8).Value = "nein" 'Spalte H
Set rngGefunden = .Columns.FindNext(after:=rngGefunden)
Loop Until rngGefunden.Address = strAdresse
End If
End With
Next
End With
Application.ScreenUpdating = True
End Sub