AW: Nicht alle benötigten Daten im Dictionary
30.09.2025 15:01:02
Christian
Hallo Udo,
danke für den Hinweis, habe das Makro entsprechend angepasst. Jetzt funktioniert es.
Gruß
Christian
Sub ListeNeueVideosUndBilder()
Dim wsVideos As Worksheet, wsBilder As Worksheet, wsUpdate As Worksheet, ws300 As Worksheet, wsMRS As Worksheet
Dim arr300 As Variant, arrMRS As Variant
Dim dictGebVideos As Object, dictGebBilder As Object, dictAlt As Object
Dim outputVideos() As Variant, outputBilder() As Variant
Dim i As Long, j As Long, nummer As Long
Dim kombiCheck As String, geburtstag As String
Dim letzteZeileVideosB As Long, letzteZeileVideosG As Long
Dim letzteZeileBilderB As Long, letzteZeileBilderG As Long
Set wsVideos = ThisWorkbook.Sheets("Videos")
Set wsBilder = ThisWorkbook.Sheets("Bilder")
Set wsUpdate = ThisWorkbook.Sheets("Update")
Set ws300 = ThisWorkbook.Sheets("300")
Set wsMRS = ThisWorkbook.Sheets("MRS")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'--- Kopfzeilen ---
wsUpdate.Cells(1, "K").Value = "neue Videos"
wsUpdate.Cells(1, "L").Value = "Quelle mit Nummer"
wsUpdate.Cells(1, "N").Value = "neue Bilder"
wsUpdate.Cells(1, "O").Value = "Quelle mit Nummer"
'--- Geburtstage für Videos (300) ---
arr300 = ws300.Range("B1:C" & ws300.Cells(ws300.Rows.count, "B").End(xlUp).Row).Value
Set dictGebVideos = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr300, 1)
If Not dictGebVideos.Exists(UCase(Trim(arr300(i, 1)))) Then
If IsDate(arr300(i, 2)) Then
dictGebVideos(UCase(Trim(arr300(i, 1)))) = Format(arr300(i, 2), "dd.mm.yyyy")
Else
dictGebVideos(UCase(Trim(arr300(i, 1)))) = ""
End If
End If
Next i
'--- Geburtstage für Bilder (MRS) ---
arrMRS = wsMRS.Range("B1:C" & wsMRS.Cells(wsMRS.Rows.count, "B").End(xlUp).Row).Value
Set dictGebBilder = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arrMRS, 1)
If Not dictGebBilder.Exists(UCase(Trim(arrMRS(i, 1)))) Then
If IsDate(arrMRS(i, 2)) Then
dictGebBilder(UCase(Trim(arrMRS(i, 1)))) = Format(arrMRS(i, 2), "dd.mm.yyyy")
Else
dictGebBilder(UCase(Trim(arrMRS(i, 1)))) = ""
End If
End If
Next i
'--- Vorhandene Kombinationen F+G sammeln ---
Set dictAlt = CreateObject("Scripting.Dictionary")
'Videos
letzteZeileVideosB = wsVideos.Cells(wsVideos.Rows.count, "B").End(xlUp).Row
letzteZeileVideosG = wsVideos.Cells(wsVideos.Rows.count, "G").End(xlUp).Row
For i = 1 To Application.WorksheetFunction.Max(letzteZeileVideosB, letzteZeileVideosG)
kombiCheck = UCase(Trim(wsVideos.Cells(i, "F").Value) & Trim(wsVideos.Cells(i, "G").Value))
If kombiCheck > "" Then dictAlt(kombiCheck) = 1
Next i
'Bilder
letzteZeileBilderB = wsBilder.Cells(wsBilder.Rows.count, "B").End(xlUp).Row
letzteZeileBilderG = wsBilder.Cells(wsBilder.Rows.count, "G").End(xlUp).Row
For i = 1 To Application.WorksheetFunction.Max(letzteZeileBilderB, letzteZeileBilderG)
kombiCheck = UCase(Trim(wsBilder.Cells(i, "F").Value) & Trim(wsBilder.Cells(i, "G").Value))
If kombiCheck > "" Then dictAlt(kombiCheck) = 1
Next i
'--- Neue Videos prüfen und schreiben ---
ReDim outputVideos(1 To letzteZeileVideosB, 1 To 2)
nummer = 1
j = 1
For i = 1 To letzteZeileVideosB
If Trim(wsVideos.Cells(i, "B").Value) > "" And Trim(wsVideos.Cells(i, "C").Value) > "" Then
kombiCheck = UCase(Trim(wsVideos.Cells(i, "B").Value) & Trim(wsVideos.Cells(i, "C").Value))
If Not dictAlt.Exists(kombiCheck) Then
geburtstag = ""
If dictGebVideos.Exists(UCase(Trim(wsVideos.Cells(i, "B").Value))) Then geburtstag = dictGebVideos(UCase(Trim(wsVideos.Cells(i, "B").Value)))
outputVideos(j, 1) = wsVideos.Cells(i, "C").Value
outputVideos(j, 2) = wsVideos.Cells(i, "A").Value & " - " & wsVideos.Cells(i, "B").Value & IIf(geburtstag > "", " " & geburtstag, "") & " " & nummer
j = j + 1
nummer = nummer + 1
End If
End If
Next i
If j > 1 Then wsUpdate.Range("K2").Resize(j - 1, 2).Value = outputVideos
'--- Neue Bilder prüfen und schreiben ---
ReDim outputBilder(1 To letzteZeileBilderB, 1 To 2)
nummer = 1
j = 1
For i = 1 To letzteZeileBilderB
If Trim(wsBilder.Cells(i, "B").Value) > "" And Trim(wsBilder.Cells(i, "C").Value) > "" Then
kombiCheck = UCase(Trim(wsBilder.Cells(i, "B").Value) & Trim(wsBilder.Cells(i, "C").Value))
If Not dictAlt.Exists(kombiCheck) Then
geburtstag = ""
If dictGebBilder.Exists(UCase(Trim(wsBilder.Cells(i, "B").Value))) Then geburtstag = dictGebBilder(UCase(Trim(wsBilder.Cells(i, "B").Value)))
outputBilder(j, 1) = wsBilder.Cells(i, "C").Value
outputBilder(j, 2) = wsBilder.Cells(i, "A").Value & " - " & wsBilder.Cells(i, "B").Value & IIf(geburtstag > "", " " & geburtstag, "") & " " & nummer
j = j + 1
nummer = nummer + 1
End If
End If
Next i
If j > 1 Then wsUpdate.Range("N2").Resize(j - 1, 2).Value = outputBilder
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub