Daten von Website per VBA importieren

03.02.2025 11:14:42

MB73

Hallo zusammen!
Seit ein paar Tagen suche ich nach einer Lösung. Da ich mich mit VBA nicht wirklich auskenne, versuche ich es auf diesem Wege.
Vielleich kann mir jemand helfen!?

Ich habe eine Tabelle mit NCS-Farb-Codes in Spalte A und in Spalte B jeweils einen Link zu einer Website. Auf diesen Seiten sind Tabellen im HTML eingebettet, die den NCS-Code in CMYK und RGB wiedergeben. Da es sich um über 2000 Farb-Codes handelt ist es natürlich denkbar mühselig alles von Hand einzugeben.
Nun ist die Herausforderung, die CMYK und RGB Daten in die Spalten neben dem Link zu importieren. Im HTML Code stehen die Daten immer in der gleichen HTML-Code-Zeile. (CMYK ab Codezeile 226 bis 229 und RGB ab Codezeile 240 bis 242)
Im Anhang ist meine Excel Datei zu finden.

https://www.herber.de/bbs/user/175445.xlsx

Vielen Dank schon mal im Voraus!!!

AW: Daten von Website per VBA importieren

03.02.2025 12:34:35

Alwin Weisangler

Hallo,

wie lange natürlich der Seitenbetreiber sich das gefallen lässt und dann Dieser entsprechende Gegenmaßnahmen ergreift wäre das so möglich:



Option Explicit

    Dim iZeile&



Sub OnVistaHolen()

    Dim Url$, arrUrl(): arrUrl = Tabelle1.Range("NCS[URL]").Value

    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    For iZeile = LBound(arrUrl) To UBound(arrUrl)

        If Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 3) = "" Or Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 7) = "" Then

            Url = arrUrl(iZeile, 1)

            Tabelle2.UsedRange.ClearContents

            Tabelle2.Activate

            With Tabelle2.QueryTables.Add(Connection:="URL;" & Url, Destination:=Range("$A$1"))

                .WebSelectionType = xlEntirePage

                .WebFormatting = xlWebFormattingNone

                .Refresh BackgroundQuery:=False

            End With

            FarbCodeEintragen

        End If

    Next

    Application.ScreenUpdating = True

End Sub



Private Sub FarbCodeEintragen()

    Dim iCMYK As Variant, iRGB As Variant, arr(1 To 1, 1 To 7)

    With Tabelle2

        iCMYK = Application.Match("CMYK code", .Columns(1), 0) + 2

        iRGB = Application.Match("RGB code", .Columns(1), 0) + 2

        arr(1, 1) = .Cells(iCMYK, 2)

        arr(1, 2) = .Cells(iCMYK + 1, 2)

        arr(1, 3) = .Cells(iCMYK + 2, 2)

        arr(1, 4) = .Cells(iCMYK + 3, 2)

        arr(1, 5) = .Cells(iRGB, 2)

        arr(1, 6) = .Cells(iRGB + 1, 2)

        arr(1, 7) = .Cells(iRGB + 1, 2)

    End With

    Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 3).Resize(1, 7) = arr

End Sub

Gruß Uwe

AW: Daten von Website per VBA importieren

03.02.2025 14:32:18

MB73

Leider gibt der VBA-Code den 3. RGB Wert nicht richtig aus?
Wo könnte da der Fehler sein?
Gruß Martin

AW: Daten von Website per VBA importieren

03.02.2025 21:24:50

Yal

Hallo zusammen,

da Uwe teilweise über eine Power Query Abfrage geht ( " ..With Tabelle2.QueryTables.Add( .. "), reiche ich einfach Version "komplett über Power Query". Es hilft Martin vielleicht nicht ganz, aber wer weißt, wer auf dieser ähnlichen Fragestellung zustosst.

Auf dem Tabelle rechtsklicken, "Daten aus Tabelle/Bereich abrufen..." klicken, und in dem Power Query Editor auf dem Erweiterte Editor gehen und den bestehende Code durch folgenden ersetzen:

let

    Quelle = Excel.CurrentWorkbook(){[Name="Tabelle1"]}[Content],

    #"Geänderter Typ" = Table.TransformColumnTypes(Quelle,{{"ColorCode", type text}, {"URL", type text}, {"C", type any}, {"M", type any}, {"Y", type any}, {"K", type any}, {"R", type any}, {"G", type any}, {"B", type any}}),

    #"Entfernte Spalten" = Table.RemoveColumns(#"Geänderter Typ",{"C", "M", "Y", "K", "R", "G", "B"}),

    #"Aufgerufene benutzerdefinierte Funktion" = Table.AddColumn(#"Entfernte Spalten", "WebAbfrage", each 

        let Erg = (URL as text) =>

            let

                Quelle = Web.Page(Web.Contents(URL)),

                Data = Table.Combine({Quelle{0}[Data], Quelle{1}[Data]}),

                #"Transponierte Tabelle" = Table.Transpose(Data),

                #"Höher gestufte Header" = Table.PromoteHeaders(#"Transponierte Tabelle", [PromoteAllScalars=true]),

                #"Geänderter Typ" = Table.TransformColumnTypes(#"Höher gestufte Header",{{"C", Int64.Type}, {"M", Int64.Type}, {"Y", Int64.Type}, {"K", Int64.Type}, {"R", Int64.Type}, {"G", Int64.Type}, {"B", Int64.Type}})

            in

                #"Geänderter Typ"

        in Erg([URL])),

    #"Erweiterte WebAbfrage" = Table.ExpandTableColumn(#"Aufgerufene benutzerdefinierte Funktion", "WebAbfrage", {"C", "M", "Y", "K", "R", "G", "B"}, {"C", "M", "Y", "K", "R", "G", "B"})

in

    #"Erweiterte WebAbfrage"

Bei 2050 Einzelwebabfrage muss man sich Zeit lassen, aber bei nur 4, geht es recht flott.

VG
Yal

AW: Daten von Website per VBA importieren

04.02.2025 05:09:12

Ulf

Hi,
fand die Lösung von Alwin schon in Ordnung, nur die Performance von Excel ließ bei mir zu wünschen übrig und das Ganze hat über 30min benötigt.
=>für ähnliche Fälle in XML-Http



Option Explicit



Public Type tCMYK

    C As Long

    M As Long

    Y As Long

    K As Long

End Type



Public Type tRGB

    R As Long

    G As Long

    B As Long

End Type



Public CMYK As tCMYK

Public RGB As tRGB



Dim iZeile&



Sub holeFarben()

    Dim Url As String

    Dim arrUrl()

    arrUrl = Tabelle1.Range("NCS[URL]").Value

'    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    For iZeile = LBound(arrUrl) To UBound(arrUrl)

        If Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 3) = "" Or Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 7) = "" Then

            Url = arrUrl(iZeile, 1)

            If rQuest(Url) Then

                FarbCodeEintragen

            End If

            Debug.Print iZeile

            DoEvents

        End If

    Next

'    Application.ScreenUpdating = True

End Sub



Private Sub FarbCodeEintragen()

    With Tabelle1.ListObjects(1).DataBodyRange

        .Cells(iZeile, 3) = CMYK.C

        .Cells(iZeile, 4) = CMYK.M

        .Cells(iZeile, 5) = CMYK.Y

        .Cells(iZeile, 6) = CMYK.K

        .Cells(iZeile, 7) = RGB.R

        .Cells(iZeile, 8) = RGB.G

        .Cells(iZeile, 9) = RGB.B

    End With

    With CMYK

        .C = 0

        .M = 0

        .Y = 0

        .K = 0

    End With

    With RGB

        .R = 0

        .G = 0

        .B = 0

    End With

    DoEvents

End Sub



Public Function rQuest(ByVal strURL As String) As Boolean

    'MSXML3 einbinden:

        'Dim asyncQ As MSXML2.XMLHTTP

        'Set asyncQ = New MSXML2.XMLHTTP

    'oder

    Dim asyncQ As Object

    Set asyncQ = CreateObject("MSXML2.XMLHTTP")

    

    Dim strText As String

    With asyncQ

        .Open "GET", strURL, False

        .Send

        If .readyState = 4 And .Status = 200 Then

            strText = .responseText

        End If

        .abort

    End With

    Set asyncQ = Nothing

    If parseText(strText) Then

        '

    End If

    rQuest = True

End Function



Public Function parseText(ByVal strText As String) As Boolean

    Dim bRet As Boolean

    Dim arrZeilen As Variant

    Dim lngZeile As Long, lngZeilen As Long

    Dim lngAb As Long

    Dim lngFinden As Long

    Dim strFinden(6) As String

    Dim strFarbe As String

       

    strFinden(0) = "C"

    strFinden(1) = "M"

    strFinden(2) = "Y"

    strFinden(3) = "K"

    strFinden(4) = "R"

    strFinden(5) = "G"

    strFinden(6) = "B"

    

    arrZeilen = Split(strText, vbLf)

    If IsArray(arrZeilen) Then

        lngZeilen = UBound(arrZeilen)

        For lngZeile = 1 To lngZeilen

            For lngFinden = 0 To 6

                lngAb = InStr(1, arrZeilen(lngZeile), strFinden(lngFinden), vbTextCompare)

                If lngAb > 0 Then

                    strFarbe = Trim(Replace(Replace(arrZeilen(lngZeile), strFinden(lngFinden), ""), "", ""))

                    Select Case lngFinden

                        Case 0

                            CMYK.C = strFarbe

                        Case 1

                            CMYK.M = strFarbe

                        Case 2

                            CMYK.Y = strFarbe

                        Case 3

                            CMYK.K = strFarbe

                        Case 4

                            RGB.R = strFarbe

                        Case 5

                            RGB.G = strFarbe

                        Case 6

                            RGB.B = strFarbe

                    End Select

                End If

            Next lngFinden

            If RGB.B > 0 Then

                Exit For

            End If

        Next lngZeile

    End If

    parseText = True

End Function

hth

Ulf

AW: Daten von Website per VBA importieren Korr. wg. HTML

04.02.2025 13:20:32

Ulf

Besser ist man kontrolliert:

Option Explicit



Public Type tCMYK

    C As Long

    M As Long

    Y As Long

    K As Long

End Type



Public Type tRGB

    R As Long

    G As Long

    B As Long

End Type



Public CMYK As tCMYK

Public RGB As tRGB



Dim iZeile&



Sub holeFarben()

    Dim Url As String

    Dim arrUrl()

    arrUrl = Tabelle1.Range("NCS[URL]").Value

'    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    For iZeile = LBound(arrUrl) To UBound(arrUrl)

        If Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 3) = "" Or Tabelle1.ListObjects(1).DataBodyRange.Cells(iZeile, 7) = "" Then

            Url = arrUrl(iZeile, 1)

            If rQuest(Url) Then

                FarbCodeEintragen

            End If

            Debug.Print iZeile

            DoEvents

        End If

    Next

'    Application.ScreenUpdating = True

End Sub



Private Sub FarbCodeEintragen()

    With Tabelle1.ListObjects(1).DataBodyRange

        .Cells(iZeile, 3) = CMYK.C

        .Cells(iZeile, 4) = CMYK.M

        .Cells(iZeile, 5) = CMYK.Y

        .Cells(iZeile, 6) = CMYK.K

        .Cells(iZeile, 7) = RGB.R

        .Cells(iZeile, 8) = RGB.G

        .Cells(iZeile, 9) = RGB.B

    End With

    With CMYK

        .C = 0

        .M = 0

        .Y = 0

        .K = 0

    End With

    With RGB

        .R = 0

        .G = 0

        .B = 0

    End With

    DoEvents

End Sub



Public Function rQuest(ByVal strURL As String) As Boolean

    'MSXML3 einbinden:

        'Dim asyncQ As MSXML2.XMLHTTP

        'Set asyncQ = New MSXML2.XMLHTTP

    'oder

    Dim asyncQ As Object

    Set asyncQ = CreateObject("MSXML2.XMLHTTP")

    

    Dim strText As String

    With asyncQ

        .Open "GET", strURL, False

        .Send

        If .readyState = 4 And .Status = 200 Then

            strText = .responseText

        End If

        .abort

    End With

    Set asyncQ = Nothing

    If parseText(strText) Then

        '

    End If

    rQuest = True

End Function



Public Function parseText(ByVal strText As String) As Boolean

    Dim bRet As Boolean

    Dim arrZeilen As Variant

    Dim lngZeile As Long, lngZeilen As Long

    Dim lngAb As Long

    Dim lngFinden As Long

    Dim strFinden(6) As String

    Dim strFarbe As String

       

    strFinden(0) = "<tr><th><span title=""Cyan"">C</span></th><td class=""value"">"

    strFinden(1) = "<tr><th><span title=""Magenta"">M</span></th><td class=""value"">"

    strFinden(2) = "<tr><th><span title=""Yellow"">Y</span></th><td class=""value"">"

    strFinden(3) = "<tr><th><span title=""Key"">K</span></th><td class=""value"">"

    strFinden(4) = "<tr><th><span title=""Red"">R</span></th><td class=""value"">"

    strFinden(5) = "<tr><th><span title=""Green"">G</span></th><td class=""value"">"

    strFinden(6) = "<tr><th><span title=""Blue"">B</span></th><td class=""value"">"

    

    arrZeilen = Split(strText, vbLf)

    If IsArray(arrZeilen) Then

        lngZeilen = UBound(arrZeilen)

        For lngZeile = 1 To lngZeilen

            For lngFinden = 0 To 6

                lngAb = InStr(1, arrZeilen(lngZeile), strFinden(lngFinden), vbTextCompare)

                If lngAb > 0 Then

                    strFarbe = Trim(Replace(Replace(arrZeilen(lngZeile), strFinden(lngFinden), ""), "</td></tr>", ""))

                    Select Case lngFinden

                        Case 0

                            CMYK.C = strFarbe

                        Case 1

                            CMYK.M = strFarbe

                        Case 2

                            CMYK.Y = strFarbe

                        Case 3

                            CMYK.K = strFarbe

                        Case 4

                            RGB.R = strFarbe

                        Case 5

                            RGB.G = strFarbe

                        Case 6

                            RGB.B = strFarbe

                    End Select

                End If

            Next lngFinden

            If RGB.B > 0 Then

                Exit For

            End If

        Next lngZeile

    End If

    parseText = True

End Function

AW: Daten von Website per VBA importieren

03.02.2025 14:56:28

Alwin Weisangler

Sorry,

da hatte versehentlich +1 geschrieben statt +2.
richtig diese Zeile so:



arr(1, 7) = .Cells(iRGB + 2, 2)

Gruß Uwe

AW: Daten von Website per VBA importieren

03.02.2025 15:11:03

MB73

Vielen Dank! 👌👍
Da hätte ich auch fast selbst drauf kommen können, wenn ich die Werte beim CMYK verglichen hätte. 🙄
Trotzdem Vielen Dank für die schnelle Unterstützung

AW: Daten von Website per VBA importieren

03.02.2025 13:07:56

MB73

@ Alwin Weisangler

Vielen Dank für die schnelle Hilfe. Das hat hervorragend funktioniert!

Gruß Martin

Daten von Website per VBA importieren

Forumthread: Daten von Website per VBA importieren

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Daten von Website per VBA importieren

Forumthread: Daten von Website per VBA importieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread