Daten zweier Tabellen anpassen mit VBA

Hallo Liebes Forum

Ich habe ein Problem bei dem ich hoffe dass ihr mir weiterhelfen könnt, ich bin echt am ende

Also ich habe 2 Excel Tabellen. Die erste Tabelle eine die jeden monat gezogen wird und dann eine Mastertabelle. Mittels Makro passe ich die mastertabelle an (das gleiche wie ein sverweis da in der Matertabelle Spalten sind die in der erstem Tabelle nicht drin sind). Das klappt soweit gut.
Aber wenn ich der ersten Tabelle ein neuer eintrag erfasst wird merkt das makro das nicht, das gleiche ist wenn in der ersten Tabelle ein eintrag gelöscht wird.
Ich denke schon die ganze zeit nach wie ich das lösen könnte.
kann mir jemand helfen bitte?

LG Hoursch

Please also mark the comments that contributed to the solution of the article

Content-Key: 3465814189

Url: https://administrator.de/contentid/3465814189

Printed on: May 6, 2024 at 20:05 o'clock

8 Comments

Latest comment

Hi,

zeig mal das Makro welches Du bereits hast.
Hört sich für mich so an als benötigst Du ein Worksheet_change Ereignis.
Mit dem Ereignis kenne ich mich zwar nicht sooooo gut aus aber ich kann mal drüber schauen.
Ansonsten weiß ich nicht wie viele VBA Profis hier im Forum vertreten sind, würde vermuten das Dir im https://office-loesung.de/p/ Forum besser geholfen werden kann. Das ist ja da drauf spezialisiert.
Solltest Du Deine Frage da auch posten, solltest Du die Beiträge miteinander verlinken (Crossposting)

VG

Hi

Das makro ist nicht besonderes. Ich bin darin eben nicht so geübt

Sub SVERWEIS_Vlookup()
Debug.Print Now

Dim i As Long, letzteZeile As Long
Dim Arbeitsmappe As Workbook
Dim Datenbasis As Worksheet, Ziel As Worksheet
Dim Bereich As Range, ZelleFirma As Range
Dim WsF As WorksheetFunction

Set Arbeitsmappe = ThisWorkbook
Set Datenbasis = Arbeitsmappe.Worksheets("ADExctract")  
Set Ziel = Arbeitsmappe.Worksheets("Master")  

letzteZeile = Datenbasis.Range("A" & Rows.Count).End(xlUp).Row  

Set Bereich = Datenbasis.Range("A1:U" & letzteZeile)  
Set WsF = Application.WorksheetFunction

For i = 3 To Ziel.Range("A" & Rows.Count).End(xlUp).Row  
    On Error Resume Next
    'Range C Masterliste Bereich ADECTRACT  
    'Ziel.Range("B" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 3, False)  
    Ziel.Range("C" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 2, False)  
    Ziel.Range("D" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 3, False)  
    Ziel.Range("E" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 4, False)  
    Ziel.Range("F" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 5, False)  
    Ziel.Range("G" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 6, False)  
    Ziel.Range("H" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 7, False)  
    Ziel.Range("I" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 8, False)  
    Ziel.Range("J" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 11, False)  
    Ziel.Range("K" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 12, False)  
    Ziel.Range("L" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 13, False)  
    Ziel.Range("M" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 14, False)  
    Ziel.Range("O" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 15, False)  
    Ziel.Range("P" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 16, False)  
    Ziel.Range("Q" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 17, False)  
    Ziel.Range("R" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 18, False)  
    Ziel.Range("S" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 19, False)  
    Ziel.Range("T" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 20, False)  
    Ziel.Range("U" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 21, False)  
    Ziel.Range("V" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 22, False)  
    Ziel.Range("W" & i).Value = WsF.VLookup(Ziel.Range("A" & i).Value, Bereich, 23, False)  
Next i

Debug.Print Now
End Sub
 

Vielen dank für deine Hilfe.

LG

Servus @Hoursch, willkommen auf Administrator.de!

Sub SyncTables()
    Dim wsMaster As Worksheet, wsData As Worksheet, rngMaster As Range, rngData As Range, f As Range, cell As Range, r As Long
    ' Master sheet  
    Set wsMaster = Sheets("Master")  
    ' Sheet mit aktuellen Daten  
    Set wsData = Sheets("ADExtract")  
    ' Suchbereich für Mastersheet ermitteln  
    Set rngMaster = wsMaster.Range("A3:A" & wsMaster.Cells(Rows.Count, "A").End(xlUp).Row)  
    ' Suchbereich für Sheet mit aktuellen Daten ermitteln  
    Set rngData = wsData.Range("A1:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row)  
    
    
    ' für jede zeile in den neuen Daten  
    For Each cell In rngData
        ' Finde die Daten in der Mastertabelle  
        Set f = rngMaster.Find(cell.Value, LookIn:=xlValues)
        
        ' Wenn es den Eintrag nicht gibt  
        If f Is Nothing Then
            ' Eintrag gibt es noch nicht, definiere die nächste leere Zeile in der Mastertabelle  
            Set f = wsMaster.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
            ' Füge neuen Wert ein  
            f.Value = cell.Value
        End If
        
        ' füge Daten aus Spalte B-H des neuen Sheets in Zeile in Spalte C-I des Masters ein  
        wsMaster.Cells(f.Row, "C").Resize(1, 7).Value = cell.Offset(0, 1).Resize(1, 7).Value  
        ' füge Daten aus Spalte K-N des neuen Sheets in Zeile in Spalte I-M des Masters ein  
        wsMaster.Cells(f.Row, "J").Resize(1, 4).Value = cell.Offset(0, 10).Resize(1, 4).Value  
        ' füge Daten aus Spalte O-W des neuen Sheets in Zeile in Spalte O-W des Masters ein  
        wsMaster.Cells(f.Row, "O").Resize(1, 9).Value = cell.Offset(0, 14).Resize(1, 9).Value  
    Next
    ' Lösche Zeilen aus dem Master wenn sie nicht in den aktuellen Daten vorhanden sind  
    With wsMaster
        For r = rngMaster.SpecialCells(xlCellTypeLastCell).Row To 3 Step -1
            If rngData.Find(.Cells(r, 1).Value, LookIn:=xlValues) Is Nothing Then
                .Rows(r).Delete
            End If
        Next
    End With
End Sub

Grüße Uwe

Hallo Uwe

Vielen dank für deine Hilfe leider bring es einen Fehler bei

 If Not rngDelete Is Nothing Then rngDelete.Delete
End Sub

Und welchen? Irgendwelche Zellen gesperrt? Klappt hier im Test einwandfrei. Wir kennen den Aufbau deines Sheets nicht.
Ansonsten Demo-Sheet zum Download stellen dann schau ich mal in dein Sheet.