Makro soll am Ende sortieren

Option Explicit
Sub FilmInfosHolen()
'Für den Internetzugriff
Dim browser As Object
Dim url As String
'Tabellennamen
Dim quellTabelle As String
Dim zielTabelle As String
Dim tempTabelle As String
Dim personenArchivTabelle As String
'MakroFortschritt
Dim anzahlFrauenSoll As Long
Dim anzahlMaennerSoll As Long
Dim speichernNachAnzahl As Long
'Zeilenverwaltung in den Tabellen
Dim ersteZeileSelection As Long
Dim letzteZeileSelection As Long
Dim naechsteZeileZielTabelle As Long
Dim naechsteZeilePersonenArchivTabelle As Long
'Unterbrechungsverwaltung
Dim nachUnterbrechungWeiter As Boolean
Dim letzteZeileTempTabelle As Long
Dim filmInListe As Range
Dim zeileQuellTabelleNachUnterbrechung As Long
'Film-Infos
Dim ttNummer As String
Dim filmTitel As String
Dim datumVeroeffentlichung As String
'Schauspieler/innen-Infos
Dim imdbCodeSchauspieler As String
Dim schauspielerName As String
Dim geburtsDatumSchauspieler As String
Dim geschlecht As String
Dim rolle As String
'Laufvariablen für Schleifen/ Schleifenabbruchbedingungen
Dim i As Long
Dim j As Long
Dim startListeAktuell As Long
Dim anzahlPersonenInListe As Long
Dim fehlDurchlaeufe As Byte
Dim debugModus As Boolean
'Prüfnummern in Quelltabelle ausgeben oder nicht
'Wenn True
'Q1 = Fehlerhaft eingelesene Setlists Frauen
'R1 = Fehlerhaft eingelesene Setlists Männer
'S1 = Fehlerhaft eingelesene Geburtsdaten
debugModus = True
'Tabellen-Namen
quellTabelle = "tt-Nummern"
tempTabelle = "Temp Links"
zielTabelle = "Film- und Schauspieler-Infos"
personenArchivTabelle = "Personen Archiv"
'Ausgewählten tt-Nummern-Bereich zum Abarbeiten festlegen
ersteZeileSelection = Selection.Row
letzteZeileSelection = Selection.Row + Selection.Rows.Count - 1
'Feststellen, in welcher Zeile es in der Ziel-Tabelle weitergeht
naechsteZeileZielTabelle = Sheets(zielTabelle).UsedRange.Rows.Count + 1
'Feststellen, in welcher Zeile es in der Personen-Archiv-Tabelle weitergeht
naechsteZeilePersonenArchivTabelle = Sheets(personenArchivTabelle).UsedRange.Rows.Count + 1
'Initialisierung der ZählVariable zum Speichern nach der
'vorgegbenen Anzahl ausgelesener Personen
speichernNachAnzahl = 0
'Prüfen, ob die Kopfzeile mit in die Auswahl einbezogen wurde
'Wenn ja, Makro mit Hinweis abbrechen
If ersteZeileSelection = 1 Then
MsgBox "Die Kopfzeile darf nicht mit in die Auswahl fallen."
Exit Sub
End If
'Prüfen, ob mindestens Schauspierinnen oder Schauspieler auf 'ja' steht
'Sonst Makro mit Hinweis abbrechen
If Sheets(quellTabelle).Cells(1, 10).Value  "ja" And Sheets(quellTabelle).Cells(1, 13). _
Value  "ja" Then
MsgBox "Es wurde weder das Auslesen von Schauspielerinnen, noch von Schauspielern  _
ausgewählt."
Exit Sub
End If
'Ausgewählte ttNummern in Quell-Tabelle durchgehen
For i = ersteZeileSelection To letzteZeileSelection
'Ab Zeile 15 in der Quelltabelle scrollt die Tabelle zeilenweise mit
If i > 14 Then
ActiveWindow.SmallScroll down:=1
End If
'Filminfos aus Quelltabelle holen
ttNummer = Sheets(quellTabelle).Cells(i, 1).Value
filmTitel = Sheets(quellTabelle).Cells(i, 2).Value
datumVeroeffentlichung = Sheets(quellTabelle).Cells(i, 3).Value
'Davon ausgehen, dass die TempTabelle leer ist
'(Keine MakroUnterbrechung beim letzten Durchgang)
nachUnterbrechungWeiter = False
'Wenn TempTabelle leer ist, dann direkt Filme abarbeiten
If Sheets(tempTabelle).Cells(1, 1) = "" Then
'Infos zu Schauspielern holen falls gewünscht
If Sheets(quellTabelle).Cells(1, 13).Value = "ja" Then
'Anzahl Personen in der Setlist auf -1 setzen
anzahlPersonenInListe = -1
'Erste Person als Startpunkt für die zu holende Setliste setzen
startListeAktuell = 1
'Alle Seiten durchgehen, wenn mehr als 100 Personen in der Liste aufgeführt  _
sind
Do
'Seite mit Links für Schauspieler mit
'hinterlegtem Geburtsdatum im IE aufrufen
url = "https://www.imdb.com/search/name?gender=male&roles=" & ttNummer & "& _
has=birth-date&sort=birth_date,desc&count=100&start=" & startListeAktuell
'Browserzugriff auf ausgelesene Werte absichern absichern
fehlDurchlaeufe = 0
Do
'Internet Explorer initialisieren und URL aufrufen
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.readyState = 4: DoEvents: Loop
'Anzahl der auszulesenden Personen der aktuellen Setliste holen
'wenn noch nicht passiert
If anzahlPersonenInListe = -1 Then
anzahlPersonenInListe = anzahlPersonenInListeHolen(browser)
End If
'Links zu den Seiten der Schauspieler in die tempTabelle einlesen
anzahlMaennerSoll = SchauspielerInfosHolen(browser, tempTabelle, "m",  _
ttNummer, filmTitel, datumVeroeffentlichung)
'Aufräumen
browser.Quit
Set browser = Nothing
If anzahlMaennerSoll = 0 And Sheets(quellTabelle).Cells(i, 7).Value  1 Then
'Wenn nicht, prüfen ob die ttNummer in der ersten Zeile der Auswahl
'eine andere ist, als die in der letzten Zeile der ZielTabelle
If Sheets(quellTabelle).Cells(ersteZeileSelection, 1).Value  Sheets( _
zielTabelle).Cells(naechsteZeileZielTabelle - 1, 1).Value Then
'Wann unterschiedlich, Schleifenzähler zurücksetzen
i = i - 1
End If
Else
'Wenn die Zieltabelle leer ist, den Schleifenzähler zurücksetzen
i = i - 1
End If
'Prüfen, ob die ttNummer und der IMDB-Code in der letzten Zeile der Zieltabelle
'identisch mit diesen Werten in der letzten Zeile der TempTabelle sind. Zusätzlich  _
prüfen,
'ob das Feld für den IMDB-Code in der letzten Zeile der Zieltabelle leer ist
'Wenn die Werte gleich sind oder der IMDB-Code in der Zieltabelle fehlt,
'die letzte Zeile in der ZielTabelle löschen und den Zeilenzähler um 1 zurücksetzen
'Sie wird automatisch neu und vollständig aufgebaut
ttNummer = Sheets(tempTabelle).Cells(letzteZeileTempTabelle, 2).Value
url = Sheets(tempTabelle).Cells(letzteZeileTempTabelle, 1).Value
If Sheets(zielTabelle).Cells(naechsteZeileZielTabelle - 1, 1).Value = ttNummer Then
If Sheets(zielTabelle).Cells(naechsteZeileZielTabelle - 1, 4).Value = Trim( _
Right(url, Len(url) - InStrRev(url, "/"))) Or _
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle - 1, 4).Value = "" Then
Sheets(zielTabelle).Rows(naechsteZeileZielTabelle - 1).Delete
naechsteZeileZielTabelle = naechsteZeileZielTabelle - 1
End If
End If
'Prüfen, ob in der PersonenArchivTabelle ein Geburtsdatum in der letzten Zeile  _
steht
'Wenn nicht, Zeile löschen und Zeilenzähler um 1 zurücksetzen
If Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle - 1, 3). _
Value = "" Then
Sheets(personenArchivTabelle).Rows(naechsteZeilePersonenArchivTabelle - 1). _
Delete
naechsteZeilePersonenArchivTabelle = naechsteZeilePersonenArchivTabelle - 1
End If
End If
'Infos in Ziel-Tabelle eintragen, wenn Schsuspieler abzuarbeiten sind
If Sheets(tempTabelle).Cells(1, 1)  "" Then
For j = Sheets(tempTabelle).UsedRange.Rows.Count To 1 Step -1
'Speichern nach vorgegebener Anzahl ausgelesener Personen sichern
speichernNachAnzahl = speichernNachAnzahl + 1
'Infos für aktuelle/n Schauspieler/in aus TempTabelle holen
url = Sheets(tempTabelle).Cells(j, 1).Value
ttNummer = Sheets(tempTabelle).Cells(j, 2).Value
filmTitel = Sheets(tempTabelle).Cells(j, 3).Value
datumVeroeffentlichung = Sheets(tempTabelle).Cells(j, 4).Value
geschlecht = Sheets(tempTabelle).Cells(j, 5).Value
schauspielerName = Sheets(tempTabelle).Cells(j, 6).Value
rolle = Sheets(tempTabelle).Cells(j, 7).Value
'Fiminfos in ZielTabelle eintragen
'ttNummer in die aktuelle Schauspielerzeile der Ziel-Tabelle übernehmen
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 1).Value = ttNummer
'filmTitel in die aktuelle Schauspielerzeile der Ziel-Tabelle übernehmen
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 2).Value = filmTitel
'DatumVeroeffentlichung in die aktuelle Schauspielerzeile der Ziel-Tabelle ü _
bernehmen
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 3).Value =  _
datumVeroeffentlichung
'Inhalte zu Schauspielern in ZielTabelle eintragen
'IMDB -Code aus der URL schneiden
imdbCodeSchauspieler = Trim(Right(url, Len(url) - InStrRev(url, "/")))
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 4).Value =  _
imdbCodeSchauspieler
'Name der Schauspielerin/ des Schauspielers
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 5).Value = schauspielerName
'Versuchen, den Geburtstag aus der Personen Archiv Tabelle auszulesen
'um den Internet-Zugriff zu vermeiden
geburtsDatumSchauspieler = geburtsDatumSchauspielerAusArchivHolen( _
personenArchivTabelle, imdbCodeSchauspieler)
'Wenn der Geburtstag nicht im Archiv war, auslesen und ins Archiv übernehmen
If geburtsDatumSchauspieler = "" Then
'Browserzugriff auf ausgelesene Werte absichern absichern
fehlDurchlaeufe = 0
Do
'Seite mit Geburtsdatum für aktuellen Schauspieler im IE aufrufen
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.readyState = 4: DoEvents: Loop
'Geburtsdatum aus Internetseite auslesen
geburtsDatumSchauspieler = GeburtsDatumHolen(browser)
'Aufräumen
browser.Quit
Set browser = Nothing
If geburtsDatumSchauspieler = "" Then
fehlDurchlaeufe = fehlDurchlaeufe + 1
If debugModus Then
Sheets(quellTabelle).Cells(1, 19).Value = Sheets(quellTabelle). _
Cells(1, 19).Value + 1
End If
If fehlDurchlaeufe = 10 Then
MsgBox "Es wurde 10x erfolglos versucht das Geburtsdatum zu  _
holen für:" & Chr(13) & schauspielerName & Chr(13) & "IMDB-Code: " & imdbCodeSchauspieler _
& Chr(13) & Chr(13) & "Es scheint ein bisher  _
unbekannter Fehler aufgetreten zu sein."
Exit Sub
End If
End If
Loop While geburtsDatumSchauspieler = ""
'IMDB-Code, Schauspielername und Geburtsdatum in Archiv Tabelle eintragen
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle, 1). _
Value = imdbCodeSchauspieler
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle, 2). _
Value = schauspielerName
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle, 3). _
Value = geburtsDatumSchauspieler
'Eintragen, dass ein Geburtsdatum aus dem Internet geholt wurde
'Steigt diese Zahl auf größer 1, hätte das Datum in der Archivtabelle stehe  _
müssen
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle, 4). _
Value = _
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle, 4) _
.Value + 1
'Zelle mit Geburtsdatum färben, wenn vor 01.01.1900
'(Kein gültiges Excel-Datum)
If Year(geburtsDatumSchauspieler) > 1899 Then
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle,  _
3).Value = _
CDate(Sheets(personenArchivTabelle).Cells( _
naechsteZeilePersonenArchivTabelle, 3).Value)
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle,  _
3).Interior.ColorIndex = xlNone
Else
Sheets(personenArchivTabelle).Cells(naechsteZeilePersonenArchivTabelle,  _
3).Interior.ColorIndex = 43
End If
'Nächste Zeile in PersonenArchivTabelle festlegen
naechsteZeilePersonenArchivTabelle = naechsteZeilePersonenArchivTabelle + 1
End If
'Geburtsdatum in ZielTabelle eintragen
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 6).Value =  _
geburtsDatumSchauspieler
'Zelle mit Geburtsdatum färben, wenn vor 01.01.1900
'(Kein gültiges Excel-Datum)
If Year(geburtsDatumSchauspieler) > 1899 Then
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 6).Value = CDate(Sheets( _
zielTabelle).Cells(naechsteZeileZielTabelle, 6).Value)
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 6).Interior.ColorIndex = _
xlNone
Else
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 6).Interior.ColorIndex = _
43
End If
'Eintragen ob Frau oder Mann
If geschlecht = "f" Then
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 7).Value = 1
Else
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 8).Value = 1
End If
'Echte Rolle der Person bei diesem Film eintragen
'(Actress, Actor, Soundtrack, Stunt, ...)
Sheets(zielTabelle).Cells(naechsteZeileZielTabelle, 9).Value = Trim(rolle)
'Letzte Zeile in TempTabelle löschen
Sheets(tempTabelle).Rows(j).Delete
'Visuelle Kontrolle, ob Makro noch läuft
If nachUnterbrechungWeiter Then
If zeileQuellTabelleNachUnterbrechung > 0 Then
If geschlecht = "f" Then
Sheets(quellTabelle).Cells(zeileQuellTabelleNachUnterbrechung, 4). _
Value = Sheets(quellTabelle).Cells(zeileQuellTabelleNachUnterbrechung, 4).Value + 1
Else
Sheets(quellTabelle).Cells(zeileQuellTabelleNachUnterbrechung, 6). _
Value = Sheets(quellTabelle).Cells(zeileQuellTabelleNachUnterbrechung, 6).Value + 1
End If
End If
Else
If geschlecht = "f" Then
Sheets(quellTabelle).Cells(i, 4).Value = Sheets(quellTabelle).Cells(i,  _
4).Value + 1
Else
Sheets(quellTabelle).Cells(i, 6).Value = Sheets(quellTabelle).Cells(i,  _
6).Value + 1
End If
End If
'Nächste Zeile Ziel-Tabelle festlegen
naechsteZeileZielTabelle = naechsteZeileZielTabelle + 1
'Nach jedem 50sten abgearbeitetem Schauspieler speichern
If speichernNachAnzahl Mod 50 = 0 Then
ActiveWorkbook.Save
End If
Next j
End If
'Null eintragen für ausgelesene Schauspieler/innen
'wenn keine mit Geburtsdatum in der Setlist waren
If Sheets(quellTabelle).Cells(i, 5).Value = 0 And Sheets(quellTabelle).Cells(i, 5). _
Value  "" Then
Sheets(quellTabelle).Cells(i, 4).Value = 0
End If
If Sheets(quellTabelle).Cells(i, 7).Value = 0 And Sheets(quellTabelle).Cells(i, 7). _
Value  "" Then
Sheets(quellTabelle).Cells(i, 6).Value = 0
End If
'Speichern, nachdem ein Film abgearbeitet wurde
ActiveWorkbook.Save
Next i
End Sub