Hallo Werner,
im Prinzip ist das ganze so aufgebaut,
in Spalte A stehen bis zu 2500 URL's, das Makro schreibt sämtliche Hyperlinks die es auf diesen Seiten findet (ca. 400 Pro Seite) in Spalte B, die Outer Texts wenn vorhanden in Spalte C.
Die Formel markiert die Zeilen, die ich dann auch wirklich benötige
und ein weiterer Teil des Makros verteilt die Daten dann auf 3 Spalten.
Das bisherige Makro hat den Vorteil dass ich es einmal starte und irgendwann ist es fertig. Es macht ja noch mehr als nur das gerade beschriebene.
Andere Lösungen wären für mich nur interessant, wenn sie ebenfalls das selbe tun wie das Makro, ohne dass ich zwischendrin nochmal eingreifen muss (will nachts nicht aufstehen und trotzdem haben dass es wenn ich aufstehe fertig ist).
Hier das Makro komplett:
Aber noch so eine Sache am Rande, ich komme an die Daten nur ran wenn ich mich bei der Internetseite anmelde. Da ich meine Anmeldedaten nicht rausgeben will wäre das schon das nächste Problem.
Sub erstesMakro()
Dim QuellBlatt As Worksheet, ZielBlatt As Worksheet
Dim Text As String, url As String, baseUrl As String
Dim i As Integer, j As Integer, BlattNr As Integer, Anzahl As Integer
Dim letzteZeile As Long, MaxEintraegeProBlatt As Long
Dim ws As Worksheet, neuesBlatt As Worksheet, cell As Range
Dim http As Object, html As Object, links As Object, link As Object
Dim lastRow As Long, outputRow As Long
Dim BlattIndex As Integer
Dim rng As Range, arr As Variant
Dim zielZeileA As Long, zielZeileB As Long, zielZeileC As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
' Filter entfernen und UsedRange setzen
Dim wksSheet As Worksheet
Dim lngCount As Long
For Each wksSheet In ThisWorkbook.Worksheets
For lngCount = wksSheet.ListObjects.Count To 1 Step -1
With wksSheet.ListObjects(lngCount)
If Not .AutoFilter Is Nothing Then
.Range.AutoFilter
End If
End With
Next lngCount
Next wksSheet ' -- This was missing
' Schritt 1: Blätter erstellen und füllen
MaxEintraegeProBlatt = 2500
Set QuellBlatt = ThisWorkbook.Sheets("Hilfe")
BlattNr = 1
letzteZeile = 1
Set ZielBlatt = ThisWorkbook.Sheets(CStr(BlattNr))
For j = 1 To 12
Text = QuellBlatt.Cells(j, 1).Value
Anzahl = QuellBlatt.Cells(j, 2).Value
For i = 1 To Anzahl
If letzteZeile > MaxEintraegeProBlatt Then
BlattNr = BlattNr + 1
Set ZielBlatt = ThisWorkbook.Sheets(CStr(BlattNr))
letzteZeile = 1
End If
ZielBlatt.Cells(letzteZeile, 1).Value = Text & i & ".html"
letzteZeile = letzteZeile + 1
Next i
Next j
' Schritt 2: URLs extrahieren
Set http = CreateObject("MSXML2.XMLHTTP")
For BlattIndex = 1 To 9
Set ws = ThisWorkbook.Sheets(CStr(BlattIndex))
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
outputRow = 1
For i = 1 To lastRow
url = ws.Cells(i, 1).Value
If url > "" Then
On Error Resume Next
http.Open "GET", url, False
http.Send
If http.Status = 200 Then
Set html = CreateObject("htmlfile")
html.body.innerHTML = http.responseText
Set links = html.getElementsByTagName("a")
baseUrl = Left(url, 23)
For Each link In links
If link.href > "" Then
If Left(link.href, 6) = "about:" Then
link.href = IIf(Right(link.href, 4) = ".jpg", _
Replace(link.href, "about:", "https:"), _
Replace(link.href, "about:/", baseUrl))
End If
ws.Cells(outputRow, 2).Value = link.href
ws.Cells(outputRow, 3).Value = link.outerText
outputRow = outputRow + 1
End If
Next link
End If
On Error GoTo 0
End If
Next i
Next BlattIndex
' Schritt 3: Formeln einfügen und auflisten
Set neuesBlatt = ThisWorkbook.Worksheets("alle")
' Zielzeilen für die jeweiligen Spalten, unter Berücksichtigung bereits vorhandener Daten
zielZeileA = neuesBlatt.Cells(neuesBlatt.Rows.Count, "A").End(xlUp).Row + 1
zielZeileB = neuesBlatt.Cells(neuesBlatt.Rows.Count, "B").End(xlUp).Row + 1
zielZeileC = neuesBlatt.Cells(neuesBlatt.Rows.Count, "C").End(xlUp).Row + 1
For BlattIndex = 1 To 9
Set ws = ThisWorkbook.Worksheets(CStr(BlattIndex))
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Set rng = ws.Range("D2:D" & lastRow)
rng.FormulaLocal = "=WENN(UND($C2="""";LINKS($C4;1)="""""""");1;WENN($D1=1;2;WENN($D1=2;3;"""")))"
rng.Value2 = rng.Value2
arr = ws.Range("D2:D" & lastRow).Value2
For i = LBound(arr, 1) To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
Select Case arr(i, 1)
Case 1
neuesBlatt.Cells(zielZeileA, 3).Value = ws.Cells(i + 1, "B").Value
zielZeileA = zielZeileA + 1
Case 2
neuesBlatt.Cells(zielZeileB, 2).Value = ws.Cells(i + 1, "C").Value
zielZeileB = zielZeileB + 1
Case 3
neuesBlatt.Cells(zielZeileC, 1).Value = ws.Cells(i + 1, "C").Value
zielZeileC = zielZeileC + 1
End Select
End If
Next i
' Entferne Duplikate
lastRow = neuesBlatt.Cells(neuesBlatt.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
neuesBlatt.Range("A1:C" & lastRow).RemoveDuplicates Columns:=Array(3), Header:=xlNo
End If
' Zielzeilen nach Duplikatenentfernung neu berechnen
zielZeileA = neuesBlatt.Cells(neuesBlatt.Rows.Count, "A").End(xlUp).Row + 1
zielZeileB = neuesBlatt.Cells(neuesBlatt.Rows.Count, "B").End(xlUp).Row + 1
zielZeileC = neuesBlatt.Cells(neuesBlatt.Rows.Count, "C").End(xlUp).Row + 1
Next BlattIndex
' Entferne alle " in Spalte A des Blatts "alle"
For Each cell In neuesBlatt.Range("A1:A" & neuesBlatt.Cells(neuesBlatt.Rows.Count, "A").End(xlUp).Row)
cell.Value = Replace(cell.Value, """", "")
Next cell
' Schritt 4: Aufräumen und Anpassen
Dim targetSheets As Variant
targetSheets = Array("1", "2", "3", "4", "5", "6", "7", "8", "9")
For Each ws In ThisWorkbook.Sheets
If Not IsError(Application.Match(ws.Name, targetSheets, 0)) Then
ws.Cells.Clear
End If
Set rng = ws.usedRange
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Kombiniertes Makro abgeschlossen!", vbInformation
End Sub
Unterm Strich frage ich mich jetzt, sollen wir wegen einem an für sich funktionierenden Makro so ein Fass aufmachen und das alles versuchen in PQ umzusetzen, wo es noch 6 weitere funktionierende Makros gibt, die teilweise um das 10fache umfangreicher sind. Wobei ich auch dank eurer Versuche hier, es umzusetzen weiß, dass sich nicht alle Formeln, die die Makros berechnen in PQ umsetzen lassen.
Ich rede sicher von diesen beiden Formeln aus dem 5. Makro
=DATEDIF(G2;C2;""YD"") hier gibt die Möglichkeit die ihr mir per PQ gegeben habt um +-1 Tag andere Ergebnisse aus als die Datedif Formel
sowie =RANG.GLEICH(G2;K$2:K2;0) da hatte selbst Günther damals keine Lösung gefunden in PQ, weil sich der Bereich mit jeder Zeile ändert. Da das aber die für mich wichtigste Formel der ganzen Mappe ist, ist sie für mich unersetzbar.
Unterm Strich sehe ich an dem Versuch das ganze in PQ zu bringen ein Fass ohne Boden.