Bestimmte Zeilen löschen oder markieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub einfaerben() Dim Schleife As Long, Zeile As Long Dim wksQ As Worksheet, wksZ As Worksheet Dim Bereich As Range Dim a As Variant Set wksQ = Worksheets("Tabelle1") Set wksZ = Worksheets("Tabelle2") wksQ.Columns(1).Interior.Color = xlNone Zeile = 1 For Schleife = 1 To wksQ.Cells(Rows.Count, 1).End(xlUp).Row Step 5 Set Bereich = wksQ.Cells(Schleife + 1, 1).Resize(3, 1) a = Application.Match(Mid(wksZ.Cells(Zeile, 1), 2, 9 ^ 9) & "*", Bereich, 0) If IsNumeric(a) Then Bereich.Cells(a).Interior.Color = vbGreen End If Zeile = Zeile + 1 Next Set wksQ = Nothing Set wksZ = Nothing Set Bereich = Nothing End Sub

Hallo Hary,
probier mal:

Sub Faerben()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle2")
Dim rng As Range
Dim i As Long, a As Long, r As Long, findRow As Long, x As Long, lngRow As Long
lngRow = wksZiel.Cells(Rows.Count, "A").End(xlUp).Row
Dim strSuche As String, rngSuche As String
a = 1
wksQuelle.Columns(1).Interior.Color = xlNone
Application.ScreenUpdating = False
For i = 1 To wksQuelle.Cells(Rows.Count, "A").End(xlUp).Row Step 5
With wksZiel
strSuche = a
For Each rng In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
If Left((rng), Len(rng) - 1) = strSuche Then
findRow = rng.Row
Exit For
End If
Next rng
End With
r = Range(Right(wksZiel.Range("A" & findRow), 1) & 1).Column
Range("A" & i + r).Interior.Color = vbGreen
a = a + 1
If a > lngRow Then Exit For
Next
Set wksQuelle = Nothing
Set wksZiel = Nothing
Set rng = Nothing
End Sub

Keine Fehlerkorrektur eingebaut.
Gruß
Klaus

Sub Faerben() Dim wksQuelle As Worksheet, wksZiel As Worksheet Set wksQuelle = Worksheets("Tabelle1") Set wksZiel = Worksheets("Tabelle2") Dim rng As Range Dim i As Long, a As Long, r As Long, findRow As Long, x As Long, lngRow As Long lngRow = wksZiel.Cells(Rows.Count, "A").End(xlUp).Row Dim strSuche As String, rngSuche As String a = 1 wksQuelle.Columns(1).Interior.Color = xlNone Application.ScreenUpdating = False For i = 1 To wksQuelle.Cells(Rows.Count, "A").End(xlUp).Row Step 5 With wksZiel strSuche = a For Each rng In .Range("A1:A" & lngRow) If Left((rng), Len(rng) - 1) = strSuche Then findRow = rng.Row Exit For End If Next rng End With r = Range(Right(wksZiel.Range("A" & findRow), 1) & 1).Column Range("A" & i + r).Interior.Color = vbGreen a = a + 1 If a > lngRow Then Exit For Next Set wksQuelle = Nothing Set wksZiel = Nothing Set rng = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Bestimmte Zeilen löschen oder markieren

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bestimmte Zeilen löschen oder markieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread