Guten Tag
Ich habe folgendes Problem und hoffe, dass Ihr mir helfen könnt:
Ich habe ein Excel Dokument mit zwei Tabelle; "T alt" und "T neu". "T alt" ist die komplette Liste und "T neu" sind die aktualisierten Preise und die eindeutig zuordnungsbare Seriennummer (Test 6). Letztere stimmen genau mit der Spalte (Test 6) von "T neu" überein.
Nun möchte ich, dass ein Makro die Datenpaare aus der "T neu" mit den Einträgen in der "T alt" vergleicht. Der zweite Eintrag (der Preis) kann sich geändert haben und soll dann in der "alten Tabelle" eingetragen und geld eingefärbt werden. Aber nur wenn er sich geändert hat. Sonst soll er einfach zum nächsten gehen.
Vielen Dank für eure Hilfe
Hallo
so???
Code:
Option Explicit
Sub tt()
On Error GoTo Fehler
Dim TB1 As Worksheet, TB2 As Worksheet, i As Integer, j As Integer
Dim Sp1 As Integer, Z1 As Integer, LR As Integer, LC As Integer, Spalte As Integer
Const APPNAME = "TT"
'*** bescheunigt das Makro
Application.ScreenUpdating = False
'*** Stammdaten Anfang
Set TB1 = Sheets("T alt") 'aus bestimmtem Blatt
Set TB2 = Sheets("T neu")
Sp1 = 1 'Spalte A
Z1 = 1 'ab Zeile
'*** Stammdaten Ende
LC = TB2.Cells(Z1, TB2.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
For i = Sp1 To LC
' ist die Spalte vorhanden?
Spalte = WorksheetFunction.CountIf(TB1.Rows(Z1), TB2.Cells(Z1, i))
'in welcher Spalte?
If Spalte > 0 Then
Spalte = WorksheetFunction.Match(TB2.Cells(Z1, i), TB1.Rows(Z1), 0)
LR = TB2.Cells(TB2.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
For j = Z1 To LR
With TB1.Cells(j, Spalte)
If .Value <> TB2.Cells(j, i) Then
'wenn anders, dann ändern
.Value = TB2.Cells(j, i)
'färben
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next j
End If
Next i
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD
Hallo Uwe,
beim drüber schauen ist mir aufgefallen, dass Du vermutlich versehentlich am Ende nicht ScreenUpdating einschaltest, sonder die Events.
@ UweD
Viel Dank für die rasche Antwort. Es funktioniert super. Dennoch gibt es noch ein Problem. Wenn die Seriennummer in "T neu" nicht vorkommt, soll es nicht den Eintrag löschen sondern diesen Wert einfach überspringen und den so stehen lassen. Ausserdem wäre es cool würde das Makro auch funktionieren wenn diese Spalten irgendwo im Dokument stehen würden,
@ Attila
Ja, stimmt. Kopierfehler.
Die Zeile kann komplett raus, da Screenupdating sich automatisch zurückstellt
(06.03.2020, 15:11)Marcinoy schrieb: [ -> ]Wenn die Seriennummer in "T neu" nicht vorkommt, soll es nicht den Eintrag löschen sondern diesen Wert einfach überspringen und den so stehen lassen
@ Marcinoy
Das verstehe ich nicht.
Das Makro arbeitet doch NUR die Spalten in
T neu durch.
Wenn die Überschrift in
T alt nicht gefundenwird, wird auch nichts gemacht.
Wird die Spaltenüberschrift in
T alt gefunden, wird die dazugehörende Spaltennummer ermittelt.
Dann wird jede Zeile dieser Spaltennummer verglichen und wenn der Wert anders ist, dann ersetzt und gefärbt.
(06.03.2020, 15:11)Marcinoy schrieb: [ -> ]Ausserdem wäre es cool würde das Makro auch funktionieren wenn diese Spalten irgendwo im Dokument stehen würden
Genau das geschieht doch
LG UweD
Hey UWED
Entschuldigung es funktioniert tatsächlich, ich habe einen Fehler gemacht. Aber wenn eine Seriennummer dort steht und beim Preis nichts, dann wir in "T alt" auch nichts eingefügt also der Preis ist dann leer. Dies soll aber nicht passieren, dann soll der alte Preis stehen bleiben.
(06.03.2020, 15:38)Marcinoy schrieb: [ -> ]Hey UWED
Entschuldigung es funktioniert tatsächlich, ich habe einen Fehler gemacht. Aber wenn eine Seriennummer dort steht und beim Preis nichts, dann wir in "T alt" auch nichts eingefügt also der Preis ist dann leer. Dies soll aber nicht passieren, dann soll der alte Preis stehen bleiben.
Folgendes Problem:
wenn „T neu“ nicht gleich lang ist Wie „T alt“ und die Seriennummern nicht in der selben Reihenfolge sind funktioniert es nicht. Und wenn Sie gleich lang sind, so wird entweder die Seriennummer oder der Preis ausgetauscht. Und die Seriennummer kann auch mehr als einmal vorkommen in „T alt“ aber nur einmal in „T neu“ dann soll aber in „T alt“ über der aktuelle Preis übernommen werden.
Hallo,
teste mal folgenden Code:
Code:
Sub preisvergleich()
Dim i As Long, j As Long
Dim feldAlt, feldNeu
Dim lngAlt As Long, lngNeu As Long
With Sheets("T alt")
lngAlt = .Cells(.Rows.Count, 1).End(xlUp).Row
feldAlt = .Range("F2:M" & lngAlt)
End With
With Sheets("T neu")
lngNeu = .Cells(.Rows.Count, 1).End(xlUp).Row
feldNeu = .Range("A2:B" & lngNeu)
End With
For i = 1 To lngAlt - 1
If IsNumeric(Application.VLookup(feldAlt(i, 1), feldNeu, 2, 0)) Then
If Application.VLookup(feldAlt(i, 1), feldNeu, 2, 0) <> feldAlt(i, 5) Then
feldAlt(i, 8) = Application.VLookup(feldAlt(i, 1), feldNeu, 2, 0)
Else
feldAlt(i, 8) = feldAlt(i, 5)
End If
End If
Next i
' Sheets("T alt").Range("J2:J" & lngAlt) = Application.Index(feldAlt, 0, 8)
Sheets("T alt").Range("M2:M" & lngAlt) = Application.Index(feldAlt, 0, 8)
End Sub
Ich überschreibe die Werte nicht, sondern liste sie in Spalte M auf.
Wenn sie überschrieben werden sollen, dann nimm das Hochkomma in der vorletzten Code Zeile raus und lösch die letzte Zeile.
Guten Morgen Atilla
Vielen Dank. Es scheint, als würde das Makro jetzt die Werte auch dann richtig anpassen falls sie in "T neu" nicht in der korrekten Reihenfolge sind. Das ist super.
Jedoch gefiel mir im Makro von @UweD ganz gut, dass auch die Spalten vertauscht werden konnten. Ausserdem übernimmt das Makro, wenn in "T neu" nichts steht auch für "T alt" ein leeres Feld. Es soll den alten Preis dann aber stehen lassen. Zudem soll, wenn die Seriennummer nicht gefunden wird, der Preis auch stehen gelassen werden. Zudem brauche ich eine Form der Markierung von geänderten Zellen.
Vielen Dank und einen schönen Samstag
PS:
Hier nochmal mein Problem...
In "T neu" sind teilweise aktualisierte Preise, welche Seriennummern (diese sind nicht zwingend nummerisch) zugeordnet sind. Die aktualisierten Preise sollen in der passenden Zeile in "T alt" eingefügt werden. Die Spaltenüberschriften sind aber immer die Gleichen in den zwei Tabellen, jedoch hat es nicht gleich viele Spalten (Auch die Reihenfolge ist nicht zwingend die Selbe in den Tabellen). Die Seriennummern sind eindeutig zuordenbar.
In "T neu" sind meist nicht alle Seriennummern vorhanden und manchmal ist auch kein oder der selbe Preis hinterlegt. In diesen zwei Fäll, soll der Preis nicht aktualisiert werden.
Wird der Preis aktualisiert, so soll er gelb eingefärbt werden.
Vielen Dank für eure Hilfe
Hallo,
unten eine neuer Vorschlag.
Folgende Vorgaben müssen erfüllt sein:
1. In beiden Tabellen heißen die Überschriften für die Seriennummern gleich.
Ich habe die Überschrift
Seriennummer genutzt. Sollte sie anders heißen, dann im Code an der Stelle, wo
"Seriennummer" steht diese ändern.
2. In beiden Tabellen heißen die Überschriften für die Preise gleich.
Ich habe die Überschrift
Preis genutzt. Sollte sie anders heißen, dann im Code an der Stelle, wo
"Preis" steht diese ändern.
Code:
Sub preisvergleich_und_faerben()
Dim i As Long, j As Long
Dim feldAlt, feldNeu
Dim lngL As Long
Dim x As Long
Dim rngZellen As Range
Dim nrSp_Alt As Long, nrSP_Neu As Long
Dim preisSp_Alt As Long, preisSP_Neu As Long
Dim strgNr_Ueberschrift As String
Dim strgPreis_Ueberschrift As String
strgNr_Ueberschrift = "Seriennummer"
strgPreis_Ueberschrift = "Preis"
With Sheets("T neu")
feldNeu = .Range("A1").CurrentRegion
nrSP_Neu = Application.Match(strgNr_Ueberschrift, .Rows(1), 0)
preisSP_Neu = Application.Match(strgPreis_Ueberschrift, .Rows(1), 0)
End With
With Sheets("T alt")
feldAlt = .Range("A1").CurrentRegion
nrSp_Alt = Application.Match(strgNr_Ueberschrift, .Rows(1), 0)
preisSp_Alt = Application.Match(strgPreis_Ueberschrift, .Rows(1), 0)
lngL = .Cells(.Rows.Count, nrSp_Alt).End(xlUp).Row
For i = 2 To lngL
x = Application.Match(feldAlt(i, nrSp_Alt), Application.Index(feldNeu, 0, nrSP_Neu), 0)
If IsNumeric(x) Then
If feldNeu(x, preisSP_Neu) <> "" Then
If feldAlt(i, preisSp_Alt) <> feldNeu(x, preisSP_Neu) Then
feldAlt(i, preisSp_Alt) = feldNeu(x, preisSP_Neu)
If rngZellen Is Nothing Then
Set rngZellen = .Cells(i, preisSp_Alt)
Else
Set rngZellen = Union(rngZellen, .Cells(i, preisSp_Alt))
End If
End If
End If
End If
Next i
.Cells(1, preisSp_Alt).Resize(lngL) = Application.Index(feldAlt, 0, preisSp_Alt)
.Cells(2, preisSp_Alt).Resize(lngL - 1).Interior.Color = xlNone
If Not rngZellen Is Nothing Then rngZellen.Interior.Color = vbYellow
End With
End Sub