Per Excel Makro mehrere Homepage Seiten als Text speichern

Hallo zusammen,
ich habe folgenden Excel Makro der sehr gut funktioniert.

Sub Links()
'  
' Links Makro  
'  

'  
    With ActiveSheet.QueryTables.Add(Connection:="URL;https://fluck-holzbau.de", _  
        Destination:=Range("$A$1"))  
        .CommandType = 0
        .Name = "fluck-holzbau.de"  
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
  
End Sub

Das Script kopiert den Text der Internetseite = Strg+A Strg+c und Strg+V.
Ich will Nur dass der Text kopiert wird. Kein Quellcode und fügt den Text dann in die Excel Spalte B ein.

Ich muss jetzt jede einzelne www. Adresse in das Makro reinschreiben

In der Excel Zeile A2 habe ich mehrere www. Adressen.

Ich hätte gerne,
daß das Makro die Adressen automatisch aus der Zeile A2 übernimmt.

Vielen Dank für eure Hilfe.

Gruß

Carlo

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 466132

Url: https://administrator.de/forum/per-excel-makro-mehrere-homepage-seiten-als-text-speichern-466132.html

Ausgedruckt am: 29.04.2025 um 10:04 Uhr

4 Kommentare

Neuester Kommentar

Hallo,

Zitat von @cdm1970:
Sub Links()

Lass das Fettschreiben indem du die zwei Sternchen wegnimmst und bitte setze deinen Code in Code-Tags. Das 2weit letzte Icon links vom Editorfenster setzt deinen code dann in Code Tags(Codeblock). Danke.

In der Excel Zeile A2 habe ich mehrere www. Adressen.

Nein, in der Zelle hast du nur einen Wert, https://fluck-holzbau.de

daß das Makro die Adressen automatisch aus der Zeile A2 übernimmt.

Und wo soll die dann hingeschrieben werden? Dein Makro erzeugt jetzt ein Kalkulationsblatt mit 358 Zeilen (Einträge) und nur in Spalte A.

Gruß,
Peter

Hallo Peter,
vielen Dank für deine Hilfe.
Ich habe den Code geändert.

Ich möchte gerne dass der Kopierte Text aus allen www. Adressen in die Spalte B kopiert wird.
Sorry das hatte ich oben vergessen zu schreiben....

Danke.

Gruß

Carlo

Hallo,

Zitat von @cdm1970:
Ich möchte gerne dass der Kopierte Text aus allen www. Adressen in die Spalte B kopiert wird.

Und wo kommen die URLs her? Soll die Spalte B komplett mit URLs aufgefüllet werden, oder reichen dir die ersten5 Zeilen (B1-B4)? Kopiere dir folgendes unter dein end with

    With ActiveSheet
        .Range("$B$1").Value = "https://fluck-holzbau.de/"  
        .Range("$B$2").Value = "https://fluck-holzbau.de/de/aktuelles.html"  
        .Range("$B$3").Value = "https://fluck-holzbau.de/de/hausbau.html"  
        .Range("$B$4").Value = "https://fluck-holzbau.de/de/objektbau.html"  
    End With

Dein Text in den Zellen A1-A4 bleibt davon unberührt, er passt halt nicht mehr

Gruß,
Peter

QueryTables ist lahm wenn es um Internet-Seiten geht.

Sub DownloadLinks()
    On Error Resume Next
    With ActiveSheet
        For Each link In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            With link.Offset(0, 1)
                 .NumberFormat = "@"  
                 .Value = DownloadStringBody(link.Value)
            End with
        Next
    End With
End Sub

Function DownloadStringBody(ByVal strURL As String) As String
    On Error GoTo Error
    Dim objhttp As Object
    Set objhttp = CreateObject("Microsoft.XMLHTTP")  
    Set oDom = CreateObject("htmlfile")  
    With objhttp
        .Open "GET", strURL, False  
        .send
        If .Status < 400 Then
            oDom.write .responseText
            DownloadStringBody = oDom.body.innerText
            oDom.Close
        Else
            DownloadStringBody = ""  
        End If
    End With
    Exit Function
Error:
    DownloadStringBody = ""  
End Function

Grüße Uwe