AW: Es bleibt dabei...
09.12.2024 14:40:59
Christian
Das kann nicht sein. Das folgende Makro, welches ich zuvor ausführe schreibt neue Texte in die Spalten M und P und lässt die Spalten N und Q unverändert, also leer. Und von Hand trage ich da auch nix ein. Es müssen also zwangsweise leere Zellen in Spalte N da sein.
Sub VerarbeiteDatenUndAktualisiere()
Dim wsNV As Worksheet
Dim letzteZeile As Long, letzteZeileD As Long, letzteZeileI As Long
Dim letzteZeileM As Long, letzteZeileP As Long, letzteZeileAE As Long, letzteZeileAF As Long
Dim dictD As Object, dictI As Object
Dim quellenRangeA As Range, quellenRangeB As Range
Dim arrA As Variant, arrB As Variant
Dim i As Long
' Arbeitsblatt festlegen
Set wsNV = ThisWorkbook.Sheets("NV")
' Bildschirmaktualisierungen und Berechnungen ausschalten
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
' Abfrage "Update" aktualisieren
wsNV.ListObjects("Update").QueryTable.Refresh BackgroundQuery:=False
' Zeilen mit Daten in den Spalten AE und AF finden
letzteZeileAE = wsNV.Cells(wsNV.Rows.Count, "AE").End(xlUp).Row
letzteZeileAF = wsNV.Cells(wsNV.Rows.Count, "AF").End(xlUp).Row
If letzteZeileAE >= 253 Then wsNV.Range("AE253:AE" & letzteZeileAE).ClearContents
If letzteZeileAF >= 253 Then wsNV.Range("AF253:AF" & letzteZeileAF).ClearContents
' Zeilen in den Spalten D und I finden
letzteZeileD = wsNV.Cells(wsNV.Rows.Count, "D").End(xlUp).Row
letzteZeileI = wsNV.Cells(wsNV.Rows.Count, "I").End(xlUp).Row
' Dictionaries für Duplikate in D und I erstellen
Set dictD = CreateObject("Scripting.Dictionary")
Set dictI = CreateObject("Scripting.Dictionary")
' D und I in Dictionaries einfügen
For i = 254 To letzteZeileD
If wsNV.Cells(i, "D").Value > "" Then dictD(wsNV.Cells(i, "D").Value) = True
Next i
For i = 254 To letzteZeileI
If wsNV.Cells(i, "I").Value > "" Then dictI(wsNV.Cells(i, "I").Value) = True
Next i
' Daten in Spalten A und B von Zeile 254 bis zur letzten Zeile einlesen
letzteZeile = wsNV.Cells(wsNV.Rows.Count, "A").End(xlUp).Row
Set quellenRangeA = wsNV.Range("A254:A" & letzteZeile)
Set quellenRangeB = wsNV.Range("B254:B" & letzteZeile)
arrA = quellenRangeA.Value
arrB = quellenRangeB.Value
' Neue Zeilen für M und P festlegen
letzteZeileM = IIf(wsNV.Cells(wsNV.Rows.Count, "M").End(xlUp).Row 253, 253, wsNV.Cells(wsNV.Rows.Count, "M").End(xlUp).Row)
letzteZeileP = IIf(wsNV.Cells(wsNV.Rows.Count, "P").End(xlUp).Row 253, 253, wsNV.Cells(wsNV.Rows.Count, "P").End(xlUp).Row)
' Werte in Spalte M und P einfügen
For i = 1 To UBound(arrA, 1)
wsNV.Cells(letzteZeileM + i, "M").Value = arrA(i, 1)
wsNV.Cells(letzteZeileP + i, "P").Value = arrB(i, 1)
Next i
' Spalte AE für Werte, die nicht in D sind
letzteZeileAE = 252
For i = 1 To UBound(arrA, 1)
If Not dictD.exists(arrA(i, 1)) And arrA(i, 1) > "" Then
letzteZeileAE = letzteZeileAE + 1
wsNV.Cells(letzteZeileAE, "AE").Value = arrA(i, 1)
End If
Next i
' Spalte AF für Werte, die nicht in I sind
letzteZeileAF = 252
For i = 1 To UBound(arrB, 1)
If Not dictI.exists(arrB(i, 1)) And arrB(i, 1) > "" Then
letzteZeileAF = letzteZeileAF + 1
wsNV.Cells(letzteZeileAF, "AF").Value = arrB(i, 1)
End If
Next i
' Duplikate in AE und AF entfernen
wsNV.Range("AE253:AE" & wsNV.Cells(wsNV.Rows.Count, "AE").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
wsNV.Range("AF253:AF" & wsNV.Cells(wsNV.Rows.Count, "AF").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
' Duplikate in den Spalten M bis R entfernen
letzteZeileM = wsNV.Cells(wsNV.Rows.Count, "M").End(xlUp).Row
wsNV.Range("M253:R" & letzteZeileM).RemoveDuplicates Columns:=Array(1, 4), Header:=xlNo
' Berechnungen und Bildschirmaktualisierungen wieder aktivieren
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Daten wurden verarbeitet, Abfrage aktualisiert, Duplikate entfernt und Berechnung wieder aktiviert!", vbInformation
End Sub