Strings vergleichen in 2 verschiedenen Tabellen
Mario
hier ist ein Code von fcs, um Namen in versch. Tabellen zu vergleichen. Mein Problem dabei ist, _
dass ich nicht erwähnt habe, dass sich die Namen im Laufe der Zeit im Tabellenblatt Woche ä _ ndern, sprich es kommt jeden Tag eine neue Zahl mit Leerzeichen dazwischen dazu. Somit würde ich gerne nicht mit der Funktion
InStr(1, sTxtB, sTxtA) > 0
Mid(sTxtA, 1, 8) = Mid(sTxtB, 1, 8)
Wenn ich nun diese aber einfach austausche, erfüllt er die True-Bedingung nicht mehr. Kann mir _ jemand helfen?
Sub Vergleichen()
Dim iSecond As Long
Dim iRowB As Long
Dim sTxtA As String, sTxtB As String
Dim bln As Boolean
Dim wksSchicht As Worksheet, wksAnwesend As Worksheet, rngZelle As Range
Dim wksWoche As Worksheet
Dim lngZeileTreffer As Long, lngZeileKeinTreffer As Long
Const FarbeKeinTreffer As Long = 6
Const FarbeTreffer As Long = 2
If MsgBox("Namen im Schichtplan mit Anwesenheitsliste vergleichen?" _
& vbLf & vbLf & "Namen werden oben gelöscht und unten eingetragen!", _
vbQuestion + vbOKCancel) = vbCancel Then Exit Sub
Set wksSchicht = Worksheets("Woche") 'Blatt mit Schichtplan
Set wksAnwesend = Worksheets("Anwesenheit") 'Blatt mit Anwesenheitsliste
Set wksWoche = Worksheets("Woche") 'Zielblatt für Ergebnisliste
' Vollzeitler ermitteln
With wksWoche
'Alteinträge löschen (Zeile 100 ggf anpassen)
' Call Trefferliste_loeschen
'Startzeile für Treffereinträge im Ergebnisblatt
lngZeileTreffer = Application.WorksheetFunction.Max(Trefferstart, _
.Cells(.Rows.Count, 2).End(xlUp).Row + 1)
lngZeileKeinTreffer = Application.WorksheetFunction.Max(Trefferstart, _
.Cells(.Rows.Count, 3).End(xlUp).Row + 1)
End With
iSecond = 3 'Spalte mit Namen in der Anwesenheitsliste
For Each rngZelle In wksSchicht.Range("B4:F" & Trefferstart + 24) 'Bereich ggf anpassen
If Not IsEmpty(rngZelle) Then 'leere Zelle überspringen
bln = False
'Name im Wochenblatt-Schichtplan
sTxtA = rngZelle.Value
'Namen aus Wochenblatt aufbereiten
'"(" links entfernen
If Left(sTxtA, 1) = "(" Then
sTxtA = Mid(sTxtA, 2)
End If
'Zeichen ab "(" entfernen
If InStr(sTxtA, "(") > 0 Then
sTxtA = Trim(Left(sTxtA, InStr(sTxtA, "(") - 1))
End If
'"Nummer" rechts entfernen
If IsNumeric(Right(sTxtA, 1)) Then
sTxtA = Trim(Left(sTxtA, InStrRev(sTxtA, " ")))
End If
With wksAnwesend
'Zeilen im Blatt Anwesend in Spalte iSecond abarbeiten
For iRowB = 3 To .Cells(.Rows.Count, iSecond).End(xlUp).Row
If IsEmpty(.Cells(iRowB, iSecond)) Then
'do nothing - leere Zelle überspringen
Else
sTxtB = .Cells(iRowB, iSecond).Value 'Name in Spalte C
'Prüfen, ob Name aus Schichtplan im Namen in Spalte C enthalten ist
If InStr(1, sTxtB, sTxtA) > 0 Then
'Treffer
bln = True
'Name in Spalte C eintragen
With wksWoche.Cells(lngZeileTreffer, 2)
.Value = rngZelle.Value
.Interior.ColorIndex = FarbeTreffer
End With
'Name im Schichtplan entfernen
With rngZelle
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
lngZeileTreffer = lngZeileTreffer + 1
Exit For
End If
End If
Next
End With
If bln = False Then
'Kein Treffer
rngZelle.Interior.ColorIndex = FarbeKeinTreffer
'Name in Spalte E eintragen
With wksWoche.Cells(lngZeileKeinTreffer, 3)
.Value = rngZelle.Value
.Interior.ColorIndex = FarbeKeinTreffer
End With
'Name im Schichtplan entfernen
With rngZelle
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
lngZeileKeinTreffer = lngZeileKeinTreffer + 1
End If
End If
Next rngZelle
End Sub
Vielen Dank
Mario
Anzeige