AW: in E100 steht ein String (also ein Text) kein Datum...
24.10.2025 13:02:06
Christian
Hallo,
ich habe jetzt auf Jochens Rat hin, das Makro geändert in Option Explicit
' === Benutzerkonfiguration ===
Const TMDB_TOKEN As String = "eyJhbGciOiJIUzI1NiJ9.eyJhdWQiOiIxMzAwNTFhOTI2YmIxZWY1ZTRjM2EyZTEyNGY0YmZjYiIsIm5iZiI6MTc1Njk5NzkyMy4zODMwMDAxLCJzdWIiOiI2OGI5YTkyM2RlNjU2M2ZkZWM4Y2RkZTAiLCJzY29wZXMiOlsiYXBpX3JlYWQiXSwidmVyc2lvbiI6MX0.K6xcskKQHVCQoeeg2OZhdTEKksGNcPi8T9wdLBQ1SV0"
Sub UpdatePersonBirthdays()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tabelle1")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If lastRow 2 Then Exit Sub ' keine Daten
Dim arrG As Variant, arrE As Variant
arrG = ws.Range("G2:G" & lastRow).Value
arrE = ws.Range("E2:E" & lastRow).Value
Dim dictURLs As Object
Set dictURLs = CreateObject("Scripting.Dictionary")
Dim i As Long, url As String, id As String, datum As Variant
Dim updated As Boolean: updated = False
' URLs sammeln und nur einmal abfragen
For i = 1 To UBound(arrG, 1)
url = Trim(arrG(i, 1))
If url > "" Then
If Not dictURLs.Exists(url) Then
id = GetTMDbID(url)
If id > "" Then
dictURLs(url) = GetPersonBirthday(id) ' Variant = echtes Datum oder Empty
Else
dictURLs(url) = Empty
End If
End If
End If
Next i
' Geburtstage eintragen und URLs löschen
For i = 1 To UBound(arrG, 1)
url = Trim(arrG(i, 1))
If url > "" Then
datum = dictURLs(url)
If Not IsEmpty(datum) Then
arrE(i, 1) = datum ' echtes Date!
arrG(i, 1) = "" ' URL löschen
updated = True
End If
End If
Next i
' Zurückschreiben
ws.Range("E2:E" & lastRow).Value = arrE
ws.Range("G2:G" & lastRow).Value = arrG
' Anzeigeformat für Excel sauber setzen
ws.Range("E2:E" & lastRow).NumberFormat = "dd.mm.yyyy"
If updated Then MsgBox "Geburtsdaten erfolgreich aktualisiert!", vbInformation, "Fertig"
End Sub
' ======================================
' TMDb-ID aus URL extrahieren (auch 12345-name)
' ======================================
Function GetTMDbID(url As String) As String
Dim parts() As String, temp As String, i As Long
parts = Split(Trim(url), "/")
For i = LBound(parts) To UBound(parts) - 1
If parts(i) = "person" Then
temp = Split(parts(i + 1), "-")(0)
If IsNumeric(temp) Then
GetTMDbID = temp
Exit Function
End If
End If
Next
GetTMDbID = ""
End Function
' ======================================
' Geburtstag als echtes Date zurückgeben
' ======================================
Function GetPersonBirthday(id As String) As Variant
Dim http As Object, url As String
Set http = CreateObject("MSXML2.XMLHTTP")
url = "https://api.themoviedb.org/3/person/" & id
http.Open "GET", url, False
http.setRequestHeader "Authorization", "Bearer " & TMDB_TOKEN
http.setRequestHeader "Content-Type", "application/json;charset=utf-8"
http.Send
If http.Status = 200 Then
Dim JSON As Object
Set JSON = JsonConverter.ParseJson(http.responseText)
If JSON.Exists("birthday") Then
If JSON("birthday") > "" Then
GetPersonBirthday = CDate(JSON("birthday")) ' echtes Datum!
Exit Function
End If
End If
End If
GetPersonBirthday = Empty ' kein Datum gefunden
End Function
so funktioniert es.
Danke
Christian