AW: Makro für Abgleich und Einfügen von Projektnamen
18.05.2017 22:59:50
Projektnamen
Hallo Rene,
hier das geänderte Makro.
Wenn sich die Zellbereiche ändern, dann musst du "nur" noch die Werte am Beginn des Makros anpassen.
LG
Franz
Sub prcAbgleich()
Dim wksNeu As Worksheet, wksVergleich As Worksheet
Dim rngVergleich As Range
Dim rngSuchen As Range
Dim zeiVergleich As Long, zeiNeu As Long, Zeile As Long
Dim spaNeu As Long, spaVergleich As Long
Dim zeiNeu_1 As Long, zeiNeu_L
Dim zeiVergleich_1 As Long, zeiVergleich_L As Long
spaNeu = 3 'Spalte C - Spalte mit den neuen Daten
zeiNeu_1 = 13 '1. Datenzeile Levl 1
zeiNeu_L = 263 'Letzte Datenzeile Levl 1
spaVergleich = 3 'Spalte C - Spalte mit den Vergleichsdaten
zeiVergleich_1 = 265 '1. Datenzeile Levl 2
zeiVergleich_L = 447 'Letzte Datenzeile Levl 2
Set wksNeu = ActiveSheet
Set wksVergleich = ActiveSheet
With wksNeu
'letzte Zeile mit neuen Daten ermitteln
zeiNeu = .Cells(zeiNeu_1 - 1, spaNeu).End(xlDown).Row
If zeiNeu > zeiNeu_L Then
MsgBox "Keine neuen Daten", _
vbOKOnly + vbInformation, "Projekte abgleichen"
Exit Sub
End If
End With
With wksVergleich
'letzte Zeile mit Vergleichsdaten ermitteln und Vergleichsbereich setzen
zeiVergleich = .Cells(zeiVergleich_1 - 1, spaVergleich).End(xlDown).Row
If zeiVergleich > zeiVergleich_L Then
'noch keine Einträge im Vergleichsbereich
zeiVergleich = zeiVergleich_1 - 1
Set rngVergleich = Nothing
Else
Set rngVergleich = .Range(.Cells(zeiVergleich_1, spaVergleich), _
.Cells(zeiVergleich, spaVergleich))
End If
End With
With wksNeu
'Daten Abgleichen
For Zeile = zeiNeu_1 To zeiNeu
Set rngSuchen = Nothing
If Not rngVergleich Is Nothing Then
'neuen Wert im Vergleichsbereich suchen
Set rngSuchen = rngVergleich.Find(what:=.Cells(Zeile, spaNeu).Value, _
LookIn:=xlValues, _
lookat:=xlWhole)
End If
If rngSuchen Is Nothing Then
zeiVergleich = zeiVergleich + 1
wksVergleich.Cells(zeiVergleich, spaVergleich) = .Cells(Zeile, spaNeu)
Else
'neuer Wert im Vergleichsbereich schon vorhanden
End If
Next Zeile
End With
End Sub