Hallo,
Ich habe jetzt bereits mehrere Versionen versucht, aber ich bekomme es einfach nicht zum Laufen.
Auch bei der Forensuche stoße ich immer wieder auf die üblichen Verdächtigen, die bei mir nicht laufen.
Ich nehme an es liegt an den Sternchen, bekomme aber zumindest bei einigen Varianten einen Wert (der Letzte) raus.
Von Vorne:
Ich habe in der Spalte "B" einen Text
Dieser könnte so aussehen:
Gefahrenmeldung (Life Safety).BI12 |
Gefahrenmeldung (Property Safty).BI13 |
Co Messung.AI3 |
Alarmmeldung BV102 |
Wartungsmeldung Filter AV110 |
Wartungsschalter.EV5 |
Betriebsmeldungen.BA15 |
Nun muss ich über VBA Die Kriterien .BI, .AI, .BV und .AV ausfiltern.
Dies habe ich am anfang nur mit "*.BI*" und "*.AI*" mit dem "Normalen Autofilter" und Operator:=xlOr gemacht und es hatte sehr gut geklappt.
Bis die beiden Kriterien BV und AV dazu kamen.
Jetzt habe ich einen neuen Code gebraucht.
Also nachgelesen und auf Array gekommen.
ActiveSheet.Range("$A$1:K" & loLetzte).Autofilter Field:=2, Criteria1:=Array("*.AI*", "*.BI*", "*.AV*", "*.BV*"), Operator:=xlFilterValues
= 0 Ergebnisse
ActiveSheet.Range("$A$1:K" & loLetzte).Autofilter Field:=2, Criteria1:=Array("*.AI*", "*.BI*", "*.AV*", "*.BV*"), Operator:=xlOr
= 1 Treffer mit BV
Also einen längeren Code genommen, der im endeffekt die Gleiche Funktion nutzt, aber alles über Variablen
'** Autofilter mit mehreren Kriterien in Spalte B setzen
'** Dimensionierung der Variablen
Dim rngFilterRange As Range
Dim lngCriteriaCount As Long
Dim arrCriteria() As String
'** Anzahl der Kriterien festlegen
lngCriteriaCount = 4
'** Variable neu dimensionieren da die Criterial mit 0 beginnen
ReDim arrCriteria(0 To lngCriteriaCount - 1)
'** Filterkriterien festlegen
arrCriteria(0) = "*.AI*"
arrCriteria(1) = "*.BI*"
arrCriteria(2) = "*.AV*"
arrCriteria(3) = "*.BV*"
'** Objektvariable setzen
Set rngFilterRange = ActiveSheet.Range("A1:K" & loLetzte)
'** Autofilter setzen/ausführen
rngFilterRange.Autofilter Field:=2, Criteria1:=arrCriteria(), Operator:=xlOr
' Filtern nach AI und BI (Analog und Digital input und Virtuelle Analog und Digitale Werte)
ActiveSheet.Range("$A$1:K" & loLetzte).Autofilter Field:=2, Criteria1:=Array("*.AI*", "*.BI*", "*.AV*", "*.BV*"), Operator:=xlFilterValues
Gleiches Ergebniss (0 Treffer, mit Operator:=xlOr letzter Treffer)
Also einen ganz anderen Code, den ich nicht aufdröseln konnte:
Dim arr1, arr2
Dim Z As Long
arr1 = Range("B1:B100").Value
ReDim arr2(1 To UBound(arr1, 1)) As String
For Z = 2 To UBound(arr1)
Select Case arr1(Z, 1)
Case "*.AI*", "*.BI*", "*.AV*", "*.BV*"
Case Else
arr2(Z) = CStr(arr1(Z, 1))
End Select
Next
Range("$B$1:$B$100").Autofilter Field:=2, Criteria1:=arr2, Operator:=xlFilterValues
Der hat mir überhaupt nichts gefiltert und mit Operator:=xlOr alles herausgefiltert
Es muss doch möglich sein mit VBA vier "Enthält" Kriterien zu Filtern. Zwei funktionieren doch auch.
Im Endeffekt möchte ich die gefilterten Zeilen in ein neues Tabellenblatt kopieren, nachdem ich in Spalte J nach 31 oder 61 gesucht habe.
Also: Wenn "B" = ("*.AI*"or "*.BI*"or "*.AV*"or "*.BV*") und ("J" = 31 or 61) dann Kopiere nach neues Sheet
Wenn es Funktioniert mit dem Filtern, habe ich es auch hinbekommen.
' Name des neuen Sheet muss auf 31 Zeichen gekürzt werden
Dim Ort31 As String
Ort31 = Left(Ort, 31)
'Neues Sheet erstellen und mit Namen versehen
Worksheets.Add.Name = Ort31
' Nach Notivication Class 31 und 61 suchen und in neues Sheet Kopieren
Dim Kopierange As Range
Dim SuchZeile As Long
' Nach 31 suchen
'Letzte Zeile feststellen
With Worksheets(QSheet.Name)
loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets(QSheet.Name)
Set Kopierange = .Rows(1)
For SuchZeile = 1 To loLetzte
If .Cells(SuchZeile, 10).Value = 31 Then
Set Kopierange = Union(Kopierange, .Rows(SuchZeile))
End If
Next SuchZeile
'Kopierange.Copy Destination:=Worksheets(Ort31).Range("A1")
End With
' Nach 61 suchen
With Worksheets(QSheet.Name)
For SuchZeile = 1 To loLetzte
If .Cells(SuchZeile, 10).Value = 61 Then
Set Kopierange = Union(Kopierange, .Rows(SuchZeile))
End If
Next SuchZeile
Kopierange.Copy Destination:=Worksheets(Ort31).Range("A1")
End With
Ich hoffe ich habe euch nicht zu sehr verwirrt, Wollte aber Zeigen, das ich durchaus nach einer Lösung gesucht habe.
Danke
|