Zellwerte mit RegEx vergleichen

Sub ZellenVergleichen() Dim lngZeile As Long Dim lngZeileMax As Long Dim zelle As Range Dim objRegEx As New RegExp Dim objMatch As MatchCollection With objRegEx .Global = False .Pattern = "\d{5}." End With With Tabelle1 lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row For lngZeile = 1 To lngZeileMax Set objMatch = objRegEx.Execute(.Range("A" & lngZeile).Value) If objMatch.Count 0 Then For Each zelle In Tabelle2.UsedRange.Columns(2) If zelle.Value = objMatch(0) Then zelle.Offset(0, -1).Copy .Cells(lngZeile, 1).Value End If Next zelle Else .rows(lngZeile).delete End If Next lngZeile End With End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Anton,
da du Zeilen in Tabelle 1 löscht musst du den Zeilen-Zähler der Schleife rückwärts laufen lassen, sonst werden Zeilen in der Auswertung nach jeder gelöschten Zeile übersprungen.
Außerdem sind in deinem Makro verschieden Syntaxfehler enthalten.

Sub ZellenVergleichen()
Dim lngZeile As Long
Dim lngZeileMax As Long
Dim zelle As Range
Dim objRegEx As New RegExp
Dim objMatch As MatchCollection
With objRegEx
.Global = False
.Pattern = "\d{5}."
End With
With Tabelle1
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
'      For lngZeile = 1 To lngZeileMax
For lngZeile = lngZeileMax To 1 Step -1
Set objMatch = objRegEx.Execute(.Range("A" & lngZeile).Value)
If objMatch.Count  0 Then
For Each zelle In Tabelle2.UsedRange.Columns(2).Cells
If zelle.Text = objMatch(0) Then
zelle.Offset(0, -1).Copy .Cells(lngZeile, 1)
End If
Next zelle
Else
.Rows(lngZeile).Delete
End If
Next lngZeile
End With
End Sub

Mit Optimierungen
- Makrobremsen vorübergehend deaktivieren
- Daten in Tabelle2 in Array einlesen
- Bei Zeilen ohne Match zunächst nur die Inhalte löschen
- Erst zum Schluss alle Leerzeilen in einer Anweisung löschen.
sieht es so aus:


Sub ZellenVergleichen_optimiert()
Dim lngZeile As Long
Dim lngZeileMax As Long
Dim objRegEx As New RegExp
Dim objMatch As MatchCollection
Dim arrTab2
Dim lngZeile2 As Long
Dim StatusCalc As Long
With objRegEx
.Global = False
.Pattern = "\d{5}."
End With
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'Vergleichsdaten in Array einlesen
With Tabelle2
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
arrTab2 = .Range(.Cells(1, 1), .Cells(lngZeileMax, 2))
End With
With Tabelle1
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngZeile = 1 To lngZeileMax
Set objMatch = objRegEx.Execute(.Range("A" & lngZeile).Value)
If objMatch.Count  0 Then
For lngZeile2 = 1 To UBound(arrTab2, 1)
If CStr(arrTab2(lngZeile2, 2)) = objMatch(0) Then
.Cells(lngZeile, 1) = arrTab2(lngZeile2, 1)
Exit For 'nach Übereinstimmung Schleife verlassen
End If
Next lngZeile2
Else
'Zeileninhalt löschen
.Rows(lngZeile).Clear
End If
Next lngZeile
Erase arrTab2
With .Range(.Cells(1, 1), .Cells(lngZeileMax, 1))
'Leerzeilen ggf. löschen
If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Gruß
Franz

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

245 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellwerte mit RegEx vergleichen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

245 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread