Hallo,
dein Namensvergleich funktioniert, nur das Schreiben der fehlenden Namen in die Messagebox hat nicht funktioniert (habe mich etwas unklar ausgedrückt).
Schau mal, ob das Makro so funktioniert, wie du willst:
Sub vergleich_neu()
Dim arrQuelle As Variant
Dim arrFehlend() As Variant
Dim lngLetzte As Long
Dim f As Long
Dim n As Long
Dim k As Long
Dim lngZeile As Long
Dim bGefunden As Boolean
Dim tMsg As String
Dim rngZelle As Range
Dim rngErgebnis As Range
Dim arrKostenstellen
' Kostenstellen definieren
arrKostenstellen = Array(1090, 4090)
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Quelldatei öffenen
Workbooks.Open ("C:\Test\Anwesenheit.xlsx")
With ActiveWorkbook
With .Worksheets("Bereich A")
'letzte beschriebene Zeile in Spalte C ermitteln
lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
'alle Daten ab Zeile 38 in Array einlesen
arrQuelle = .Range("C38:H" & lngLetzte)
End With
'Quelldatei wieder schließen; Änderungen nicht speichern
.Close (False)
End With
'arrFehlend redimensionieren
ReDim arrFehlend(lngLetzte, 3) As Variant
With ThisWorkbook.Worksheets("Stunden")
'letzte beschriebene Zeile in Spalte A ermitteln
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'Namen aus arrQuelle mit Namen in Tabelle vergleichen
For n = LBound(arrQuelle, 1) To UBound(arrQuelle, 1)
bGefunden = False 'Marker zurücksetzen
'Namen nur bei Kostenstelle 1090 oder 4090 überprüfen
If arrQuelle(n, 6) = arrKostenstellen(0) Or arrQuelle(n, 6) = arrKostenstellen(1) Then
'aktuelle Tabelle durchlaufen
For lngZeile = 8 To lngLetzte
If .Cells(lngZeile, 1).Value = arrQuelle(n, 1) Then
.Cells(lngZeile, 2) = arrQuelle(n, 2) 'Vorname in Spalte B
.Cells(lngZeile, 3) = arrQuelle(n, 3) 'Pers. ID in Spalte C
.Cells(lngZeile, 5) = arrQuelle(n, 6) 'Kostenstelle in Spalte E
.Cells(lngZeile + 1, 5) = arrQuelle(n, 6) 'Kostenstelle in Spalte E eine Zeile tiefer
bGefunden = True 'Marker für gefunden
End If
Next lngZeile
'falls nichts gefunden, dann Nachricht schreiben
If bGefunden = False Then
tMsg = tMsg & "Name: " & arrQuelle(n, 1) & ", Vorname: " & arrQuelle(n, 2) & ", Kostenstelle: " & arrQuelle(n, 6) & vbNewLine
'und Daten in arrFehlend schreiben
arrFehlend(f, 0) = arrQuelle(n, 1) 'Name
arrFehlend(f, 1) = arrQuelle(n, 2) 'Vorname
arrFehlend(f, 2) = arrQuelle(n, 3) 'Pers. ID
arrFehlend(f, 3) = arrQuelle(n, 6) 'Kostenstellen
'Zähler erhöhen
f = f + 1
End If
End If
Next n
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
' Wenn es Abweichungen gibt, zeigen Sie eine MsgBox an
If tMsg <> "" Then
If MsgBox("Es gibt Abweichungen:" & vbNewLine & tMsg & vbNewLine & "Möchten Sie diese übernehmen?", vbYesNo) = vbYes Then
' Übernehmen Sie die Änderungen
For k = 0 To 1
'letzten Eintrag für Kostenstellen suchen
With .Range("E:E")
Set rngErgebnis = .Find(arrKostenstellen(k), LookIn:=xlValues, lookat:=xlWhole)
End With
If Not rngErgebnis Is Nothing Then
lngZeile = rngErgebnis.Row
'Schleife zum Suchen der nächsten Eintragszeile
Do Until .Cells(lngZeile, 5) = ""
lngZeile = lngZeile + 1
Loop
Else
'falls noch kein Eintrag vorhanden, dann unten einfügen
lngZeile = .Cells(Rows.Count, 5).End(xlUp).Row + 10
End If
'Daten in Blatt schreiben
For n = 0 To f - 1
If arrFehlend(n, 3) = arrKostenstellen(k) Then
'2 neue Zeilen einfügen
.Rows(lngZeile & ":" & lngZeile + 1).Insert
'Daten in Blatt schreiben
.Cells(lngZeile, 1) = arrFehlend(n, 0) 'Name
.Cells(lngZeile, 2) = arrFehlend(n, 1) 'Vorname
.Cells(lngZeile, 3) = arrFehlend(n, 2) 'Pers.ID
.Cells(lngZeile, 5) = arrFehlend(n, 3) 'Kostenstelle
.Cells(lngZeile + 1, 5) = arrFehlend(n, 3) 'Kostenstelle
'Rahmen
With .Range(.Cells(lngZeile, 1), .Cells(lngZeile + 1, 16))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
End If
Next n
Next k
End If
'Datei speichern
ThisWorkbook.Save
End If
End With
End Sub
Gruß
M.O.