AW: mit Zählenwenn()
16.12.2021 14:26:42
Niklas
Vielen Dank für die Hilfe.
Ich habe jetzt folgendes bei Herber gefunden, welches funktioniert.
Sub Vgl()
Dim lngZMax As Long
Dim rngBereichId As Range
Dim wksBlatt As Worksheet
Dim wksBlattVgl As Worksheet
Dim wksBlattZ As Worksheet
Dim s As Long
Dim x As Long
Dim y As Long
Dim z As Long
x = 2
s = 0
Set wksBlatt = ThisWorkbook.Worksheets("Tabelle2")
Set wksBlattVgl = ThisWorkbook.Worksheets("Tabelle1")
Set wksBlattZ = ThisWorkbook.Worksheets("Tabelle3")
With wksBlatt
.Range("A1:F1").Copy wksBlattZ.Range("A1")
lngZMax = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rngBereichId = wksBlattVgl.Range("A2:a" & wksBlattVgl.Cells(.Rows.Count, 1).End(xlUp). _
Row)
wksBlattZ.Range("A2:F" & .Cells(.Rows.Count, 2).End(xlUp).Row).ClearContents
For w = 2 To lngZMax
If Application.WorksheetFunction.CountIf(rngBereichId, wksBlatt.Cells(w, 1)) = 0 Then
wksBlattVgl.Cells(w, 1).EntireRow.Insert
.Cells(w, 2).EntireRow.Copy wksBlattZ.Cells(x, 1)
x = x + 1
ElseIf wksBlattVgl.Cells(w, 2).Value .Cells(w, 2).Value Then
.Cells(w, 2).EntireRow.Copy wksBlattZ.Cells(x, 1)
x = x + 1
ElseIf wksBlattVgl.Cells(w, 2).Value = .Cells(w, 2).Value And wksBlattVgl.Cells(w, 5). _
Value .Cells(w, 5).Value Then
For i = 1 To Len(.Cells(w, 5))
If Mid(wksBlattVgl.Cells(w, 5), i, 1) Mid(.Cells(w, 5), i, 1) Then
.Cells(w, 5).Characters(Start:=i, Length:=i).Font.Color = RGB(255, 0, 0)
End If
Next i
For z = Len(.Cells(w, 5)) To 1 Step -1
If Mid(.Cells(w, 5), z, 1) = Mid(wksBlattVgl.Cells(w, 5), Len(wksBlattVgl. _
Cells(w, 5)) - s, 1) Then
.Cells(w, 5).Characters(Start:=z, Length:=z).Font.Color = RGB(10, 0, 0)
Else
GoTo sprung
End If
s = s + 1
Next z
sprung:
.Cells(w, 5).EntireRow.Copy wksBlattZ.Range("A" & x)
x = x + 1
End If
s = 0
Next w
End With
With wksBlattVgl
For y = .Cells(.Rows.Count, 2).End(xlUp).Row To 1 Step -1
If IsEmpty(.Cells(y, 1).Value) Then
.Cells(y, 1).EntireRow.Delete
End If
Next y
End With
End Sub
MfG
Niklas