Werte in zwei Dateien vergleichen und ändern wenn verschieden

[Marcinoy]

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

[UweD]

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

[atilla]

Hallo Uwe,

beim drüber schauen ist mir aufgefallen, dass Du vermutlich versehentlich am Ende nicht ScreenUpdating einschaltest, sonder die Events.

[Marcinoy]

@ 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,

[UweD]

@ Attila

Ja, stimmt. Kopierfehler.

Die Zeile kann komplett raus, da Screenupdating sich automatisch zurückstellt

---

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.

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

[Marcinoy]

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.

[Marcinoy]

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.

[atilla]

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.

[Marcinoy]

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

[atilla]

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