ich bitte um Eure Hilfe. Ich arbeite gerade an einer Excel-Datei, bei der Werte von einer Tabelle (bestimmte Spalte) in eine andere kopiert werden soll. Anbei die weiteren Details:
Vorabinfo:
Tabelle 1 = Zieldatei (Testtabelle-N)
Tabelle 2 = Ausgangsdatei (testtabelle-O)
Ziel:
Zellen-Daten, die gelb markiert sind aus Tabelle 2 in Tabelle 1 zu kopieren, wenn entweder Name, oder Nummer gleich sind.
Ist Nummer und Name gleich => Wert kopieren
Ist nur Nummer gleich => vorliegenden Wert kopieren und zelle grün färben
Ist nur Name gleich => vorliegenden Wert kopieren und zelle grün färben
Ist weder Nummer noch Name gleich ==> Zelle rot färben.
Problem:
Bei einer einfachen Situation funktioniert soweit der Code. Sprich: Wenn Tabelle 1 (Zieldatei) genauso aufgebaut ist wie Tabelle 2 (Ausgangsdatei). Jetzt ist es aber so, dass Tabelle 1 sich leicht unterscheiden kann. Zum Beispiel kann ein weiterer Name in einer vorhergegangenen Spalte eingefügt sein und sich somit die Zeilen um eins nach unten verschieben. Wird der Code nun ausgeführt werden nicht mehr alle Werte kopiert und übertragen, sondern die letzte Zeile fehlt.
Frage:
Seht ihr eine Möglichkeit, dass die Werte alle übertragen werden, auch wenn weitere neue Zeilen in der Zieltabelle zugefügt sind?
Code:
Sub Apply_VLookup()
'Kalkulaion der Daten
Dim i As Integer
Dim j As Integer
Dim s As Integer
Dim nbOnNewSheet As Long
Dim nbOnOldSheet As Long
Dim nameOnNewSheet As String
Dim nameOnOldSheet As String
Application.ScreenUpdating = False
'letzten Zeileindex angeben
j = 1000
'Spaltenindex für SVerweis, Y Spalte
s = 25
For i = 1 To j
If ThisWorkbook.Sheets(2).Cells(i, s).Interior.ColorIndex = 6 Then
'Standardmäßig rot, wird im dann entweder umgefärbt oder bleibt rot
ActiveWorkbook.Sheets(1).Cells(i, s).Interior.ColorIndex = 3
For x = 1 To j
'Vergleiche Materialnummer in H Spalte
If ActiveWorkbook.Sheets(1).Cells(i, 8).Value = ActiveWorkbook.Sheets(2).Cells(x, 8) _
_
_
_
_
_
.Value Then
ActiveWorkbook.Sheets(2).Cells(x, s).Copy Destination:=ActiveWorkbook.Sheets(1). _
_
_
_
_
_
Cells(i, s)
ActiveWorkbook.Sheets(1).Cells(i, s).ClearFormats
Exit For
'Wenn Wert nicht gleich, dann vergleiche Namen in R Spalte
ElseIf ActiveWorkbook.Sheets(1).Cells(i, 18).Value = ActiveWorkbook.Sheets(2).Cells( _
_
_
_
_
_
x, 18).Value Then
ActiveWorkbook.Sheets(2).Cells(x, s).Copy Destination:=ActiveWorkbook.Sheets(1). _
_
_
_
_
_
Cells(i, s)
ActiveWorkbook.Sheets(1).Cells(i, s).ClearFormats
ActiveWorkbook.Sheets(1).Cells(i, s).Interior.ColorIndex = 4
Exit For
End If
Next
End If
Next
Application.ScreenUpdating = True
MsgBox "Die Berechnung und der Vergleich der gewünschten Daten ist erfolgreich!"
End Sub
Ich habe beide Tabellen in vereinfachter Form beigefügt: