Excel VBA Werte von 2 verschiedenen Sheets vergleichen und aktualisieren

Hallo allerseits,

zurzeit arbeite ich ein einer Excel-Datenbank für Kundenverträge. Mir fehlt noch eine Kleinigkeit, bis sie komplett einsatzbereit ist.
Ich erkläre kurz den Hintergrund, damit mein Anliegen etwas verständlicher wird.
Ich besitze 2 Tabellen(Tabelle1,Tabelle2). In beiden befinden Kundendaten. Eine Zeile==> 1 Vertrag mit dazugehörigen Kundendaten(Name,Wohnort,etc.).

In Tabelle1 sind diese Verträge nicht abgeschlossen, in Tabelle2 schon. Man nimmt aus Tabelle1 die Daten, geht zum Kunden und schließt den Vertrag ab, diese Daten kommen automatisch(per Internet) in Tabelle2. Jetzt können sich aber die Werte(Kundendaten) nach dem Abschluss verändert haben. Deswegen sollen Tabelle 2 und 1 verglichen werden .Dabei sollen 5 Werte pro Zeile(nehmen wir an Spalte Nr.1,2,3,4(Name,Vorname,PLZ,Anschluss)) in Tabelle1 mit 5 Werten aus Tabelle2(Spalte Nr.6,7,8,9) verglichen werden. Stimmen die Werte überein, so soll die ganze Zeile in Tabelle1 mit der Zeile aus Tabelle2 überschrieben werden. Bei keiner Übereinstimmung soll die Zeile in Tabelle2 in eine Neue Zeile in Tabelle1 geschrieben werden. Sozusagen eine Aktualisierung.
Leider habe ich keinen Schimmer wie ich den Vergleich und die Überschreibung programmieren soll, ich hoffe ihr könnt mir weiter helfen.
Welche Zelle in der Zeile(Tabelle2) zu welcher Zelle in der anderen Zeile(Tabelle1) muss ich dann natürlich selber anpassen.

MfG

drimrim

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 312995

Url: https://administrator.de/forum/excel-vba-werte-von-2-verschiedenen-sheets-vergleichen-und-aktualisieren-312995.html

Ausgedruckt am: 30.01.2025 um 18:01 Uhr

4 Kommentare

Neuester Kommentar

Found this for you
Excel VBA gefilterte Spalten vergleichen

Would be nice to show us a picture of your sheets and how they are organized.

Regards

Hi,

Sheet 1 :

Range: A:BF

Sheet 2 :

Range: A:BA

I will get the contract informations from the web and put them into Sheet 2. Now Sheet 2 needs to be compared to Sheet 1 with 5 Values of one row. If they match, the hole row in Sheet1 needs to be overwritten by the row from Sheet2. If there is no match, the data of the row in Sheet2 still needs to be written in Sheet1, but in a new row.

I hope that I explained it well.

Regards, drimrim

Sub CompareAndUpdate()
    Dim ws1 As Worksheet, ws2 As Worksheet, cell As Range, firstAddress As String, f As Range, found As Boolean, intDestRow As Long
    'Sheets (adjust to your needs)  
    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)
    
    'Compare columns (adjust to your needs, maintain same array position between source and destination)  
    arrCompareSource = Array("K", "L", "M", "N")  
    arrCompareDestination = Array("P", "Q", "R", "S")  
    
    'column mapping (adjust to your needs, maintain same array position between source and destination)  
    arrColSource = Array("K", "L", "M", "N", "O", "P", "Q", "R","S")  
    arrColDestination = Array("P", "Q", "R", "S", "T", "U", "V", "W","X")  
    
    
    For Each cell In ws2.Range("A2:A" & ws2.Range("A1").CurrentRegion.SpecialCells(xlCellTypeLastCell).Row)  
        found = False
        With ws1.Range(arrCompareDestination(0) & "2:" & arrCompareDestination(0) & ws1.Cells(Rows.Count, arrCompareDestination(0)).End(xlUp).Row)  
            Set f = .Find(ws2.Cells(cell.Row, arrCompareSource(0)), LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                firstAddress = f.Address
                Do
                    For i = 0 To UBound(arrCompareSource)
                        c2 = c2 & ws2.Cells(cell.Row, arrCompareSource(i)).Value & "|"  
                        c1 = c1 & ws1.Cells(f.Row, arrCompareDestination(i)).Value & "|"  
                    Next
                    If c1 = c2 Then
                        found = True
                        Exit Do
                    End If
                    Set f = .FindNext(f)
                Loop While Not f Is Nothing And f.Address <> firstAddress
            End If
        End With
        
            
        If found = True Then
            intDestRow = f.Row
        Else
            intDestRow = ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row  
        End If
        
        For i = 0 To UBound(arrColSource)
            ws2.Cells(cell.Row, arrColSource(i)).Copy Destination:=ws1.Cells(intDestRow, arrColDestination(i))
        Next
    Next
End Sub