AW: In einer Spalte suchen, auch mit Platzhaltern
05.08.2005 08:24:11
bst
Guten Morgen,
hatte Gestern nicht gesehen daß Du den Thread noch als offen markiert hast und Dir
das kommentierte Teil an Deine Mail-Addie geschickt...
FWIW, hier einfach nochmal dieses reinkopiert.
cu, Bernd
--
Hallo Sören,
hier ein bischen kommentiert. Da Du ja eigentlich kein Array brauchst, würde es hier auch einfacher gehen.
cu, Bernd
--
Option Explicit
' Anmerkung: Da hier nun in einen Range geschrieben wird könnte man sich
' den gesamten Array-Schickschnack sparen !!
Sub SuchenMitRE()
Dim src As Range ' Hierin wird gesucht
Dim cell As Range ' Ein Zelle in src für die Schleife
Dim re As Object ' ein Regular Expression Objekt
Dim ar() As String ' ein Array für die gefundenen Werte
Dim arCount As Long ' Zähler für Elemente im Array, bzw. korrekter:
' Anzahl der Elemente - 1 = Index des aktuellen Elements
' Test ob Suchmuster leer
If Trim(Range("A1").Value) = "" Then
MsgBox "Suchmuster in Zelle A1 fehlt"
Exit Sub
End If
' Array-Index startet ab 0, deshalb Index = -1 um später +1 addieren zu können
arCount = -1
' erstellt ein RE-Objekt
Set re = CreateObject("vbscript.regexp")
' weist dem das Pattern (Suchmuster) zu
re.pattern = Range("A1").Value
' einfacher Test, ob's einen Fehler im Suchmuster gibt
' zum Testen wird einfach ein Leerstring genommen, sollte immer reichen
On Error Resume Next
re.test ""
If Err.Number <> 0 Then
MsgBox "Fehler in Suchmuster in Zelle A1"
Exit Sub
End If
On Error GoTo 0
' src = alle Zellen in Spalte D
Set src = Range("D1:D" & Cells.SpecialCells(xlCellTypeLastCell).Row)
' Schleife über alle Zellen in src
For Each cell In src
' Falls der Zellwert das Suchmuster 'matched', liefert re.Test TRUE
If re.test(cell.Value) Then
' ein Element mehr im Array
arCount = arCount + 1
' dafür Speicher holen aber alte Werte behalten
ReDim Preserve ar(arCount)
' Und noch den Wert eintragen
ar(arCount) = cell.Value
End If
Next
' In arrcount steht der letzte benutzte Index, falls er z.B. 4 ist
' existieren 4 + 1 (!) Elemente mit den Indices 0, 1, 2, 3, 4.
' Range() = ar() 'will eigentlich' ein 2-Dim Feld mit Zeilen&Spalten
' deshalb wird die 1-Dim 'Zeile' in eine 1-Dim Spalte transponiert
' ist sich wohl ein bischen Tricky
If arCount >= 0 Then Range("B4:E" & arCount + 4) = _
Application.WorksheetFunction.Transpose(ar)
' Anständige Leute geben am Ende Objekte wieder frei
Set re = Nothing
End Sub