alsdorf2011
22.05.2011, aktualisiert um 09:26:18 Uhr
view12459
view4
0
Goto Top

EXCEL Webabfrage per VBA Script erweitern.

FrageMicrosoft OfficeMicrosoft
Hallo,
da ich selber keine Ahnung von VBA unter Excel habe habe ich mir bisher immer per Aufzeichnungsmodul geholfen. Ich komm aber an eine Stelle nun nichtm ehr weiter.

Ich habe eine Webabfrage manuell erstellt. Jetzt suche ich eine Möglichkeit, welcher mit eine Webabfrage automatisch aus dieser Datenbank erstellt.
Die Abzufragende URL ist immer gleich aufgebaut, enthält aber immer Zahlen die in der u.g. Excel Tabelle stehen.

Aufbau (beispiel Zahlen sind immer 5 Stellig und x Anzahl von Spalten).

Spalten:
Zeile

A B C D E F G ....

1 TEXTZelle

2 123 Default 123

3 456 Default 456 789

4 789 Default 789 012 345 678 901

5 012 Default 012

6 345 Default 345 678 901
...


bisher hab ich jede Abfrage versucht einzelnt in das VBA zu bringen:

Sheets("Tabelle2").Select  
    Range("A1").Select  
Range("A:Z").Delete  

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c123&d=123&srm=services" _  
        , Destination:=Range("$A$1"))  
        .Name = _
        "daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c123&d=123&srm=services_2"  
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"  
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    On Error Resume Next
    
    Sheets("Tabelle2").Select  
    Range("A40").Select  
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c456&d=456&srm=services" _  
        , Destination:=Range("$A$40"))  
        .Name = _
        "daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c456&d=456&srm=services_2"  
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"  
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    On Error Resume Next

der Part:
"URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c456&d=456&srm=services" _
und
"daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c456&d=456&srm=services_2"


Die URL soll sich aus den Werte der Spalte A und darauffolgenden die Spalten zusammen setzen
Es gibt immer feste URL Werte, aber auch Variablen aus den Spálten ...."URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c" & "Wert aus Spalte A" & "&d=" & "Wert aus
Spalte A; B; C; D" & "&srm=services" _"

Wie bekomme ich es hin, dass hier im VBA automatisch Webanfragen geniert werden die sich Werte aus der Tabelle zieht und zwar so lange bis keine Felder mit Informationen erhalten
Gleichzeitig die Werte aber nicht überschreiben, sondern immer mit 40 Zeilen Abstand abfragt?

Zu Komplext?. kann gerne eine Beispieldatei zukommen lassen
ShareTeilen
Auf Facebook teilen Auf X (Twitter) teilen Auf Reddit teilen Auf Linkedin teilen

Content-ID: 166686

Url: https://administrator.de/forum/excel-webabfrage-per-vba-script-erweitern-166686.html

Ausgedruckt am: 18.04.2025 um 22:04 Uhr

4 Kommentare
Neuester Kommentar
Goto Top
76109
76109 22.05.2011 um 15:10:20 Uhr
Goto Top
Hallo alsdorf2011!

Das mit den Variablen habe ich nicht so ganz verstanden, insoweit es Deine Beispiel-Daten angeht. Von daher habe ich mal vier Variablen angenommen und zwar die Spalten A,B,C,D. Das kannst Du aber leicht entsprechend anpassen, indem Du die Codezeile 20 und die Konstante 'WebUrl' entsprechend anpasst.

In der Codezeile 20 werden die Spalten A,B,C,D an die Funktion 'GetUrl' übergeben und die Variablen (%1-%4) im 'WebUrl'-String durch diese Werte ersetzt. Es können
maximal 6 Werte den Variablen %1-%6 zugeordnet werden z.B GetUrl(WebUrl, A, B, C, D, E, F) -> %1=A, %2=B, %3=C usw. Jedoch muss mindestens ein Parameter übergeben werden.

Option Explicit

Private Const SheetDaten = "Tabelle1"   'Tabellenname mit Daten  
Private Const SheetQuery = "Tabelle2"   'Tabellenname für den Web-Import  

Private Const StartDaten = 2            'Tabelle Daten ab Zeile  
Private Const StartQuery = 1            'Tabelle Query ab Zeile  

Private Const BreakQuery = 40           'Tabelle Query Zeilenversatz  

Private Const WebUrl = "URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.deehqap081vwdum.c%1&d=%1%2%3%4&srm=services"  

Sub Start()
    Dim WebSite As String, EndLine As Long, NextLine As Long, i As Long

    With Sheets(SheetDaten)
        EndLine = .Cells(.Rows.Count, 1).End(xlUp).Row:  NextLine = StartQuery
        
        For i = StartDaten To EndLine
            WebSite = GetUrl(WebUrl, .Cells(i, 1), .Cells(i, 2), .Cells(i, 3), .Cells(i, 4))
            Call QueryTableImport(Sheets(SheetQuery), WebSite, NextLine)
            NextLine = NextLine + BreakQuery
        Next
    End With
End Sub

Private Sub QueryTableImport(ByRef Wks, ByRef WebSite, Optional ByVal Line As Long = 1)
    On Error Resume Next
    With Wks
        If Line = 1 Then .Cells.Clear
        With .QueryTables.Add(Connection:=WebSite, Destination:=.Cells(Line, 1))
            .AdjustColumnWidth = True
            .PreserveFormatting = True
            .WebSelectionType = xlSpecifiedTables
            .WebTables = "1"  
            .Refresh BackgroundQuery:=False
            .Delete
        End With
        If Err Then .Cells(Line, 1) = "Seite konnte nicht gefunden/geöffnet werden! "  
    End With
    On Error GoTo 0
End Sub

Private Function GetUrl(ByRef StrUrl, ByVal Str1$, Optional ByVal Str2$, Optional ByVal Str3$, _
                  Optional ByVal Str4$, Optional ByVal Str5$, Optional ByVal Str6$) As String
    
    Dim Arg as Variant, i As Integer
    
    GetUrl = StrUrl:    Arg = Array("", Str1, Str2, Str3, Str4, Str5, Str6)  
    
    For i = 1 To 6
        GetUrl = Replace(GetUrl, "%" & (i), Arg(i))  
    Next
End Function

Gruß Dieter
alsdorf2011
alsdorf2011 23.05.2011 um 11:23:51 Uhr
Goto Top
Hallo Dieter, danke für das Script.

Leider funktioniert das nicht so wie ich es gedacht habe
Habe nun es ein wenig vereinfacht:
in der Tabelle stehen jetzt alle URL untereinander

Wenn die die Möglichkeit hättest, wäre es lieb das Script nochmal so anzupassen, dass er sich nur die URLS aus der Tabelle 1 Spalte A ziehen soll
aber wie gewohnt mit 40 Zeilen abstand ( wie ja oben in deinem Script beschrieben) die Webabfragen erzeugt

Danke schön für die Hilfe
alsdorf2011
alsdorf2011 24.05.2011 um 09:52:00 Uhr
Goto Top
Hallo nochmal,

wie bekomme ich es hin, dass er bei der Datenabfrage z.b 5-10 sec wartet, bis die Datensätze ordnungsgemäß geladen wurden.
Bekomme hier gut die Hälfte an Datwensätze nicht angezeigt.

"Seite konnte nicht gefunden/geöffnet werden! 2

obwohl wenn ich die URL von Hand abfrage er sich Daten zieht.
76109
76109 24.05.2011 um 11:27:06 Uhr
Goto Top
Hallo alsdorf2011!

Mit diesem Code werden die Url's direkt aus der Tabelle erzeugt. Verwendet wurden die Beispiel-Daten aus diesem Thread: Per VBA URL aus einzelne Zellen zusammen setzen

Eine extra Pause ist eigentlich nicht erforderlich, da die Anweisung in Codezeile 59 besagt, dass die Ausführung des Codes warten soll, bis die Abfrage beendet ist.
Wenn die Webabfrage also nicht funktioniert, dann muss der Fehler woanders liegen.

Hier der neue Code (Tabellennamen anpassen):
Option Explicit

Private Const SheetDaten = "Tabelle1"   'Tabellenname mit Daten  
Private Const SheetQuery = "Tabelle2"   'Tabellenname für den Web-Import  

Private Const StartDaten = 2            'Tabelle Daten ab Zeile  
Private Const StartQuery = 1            'Tabelle Query ab Zeile  

Private Const BreakQuery = 40           'Tabelle Query Zeilenversatz  

Private Const WebUrl = "URL;http://10.112.230.xxx/admin/daemons?rm=service&sid=873fc6d94d1d583a1f07e9c32d973a9c&ctx=c2comsrvd.%1.%2&d=%3&srm=services"  

Sub Start()
    Dim RngA As Range, RngX As Range, EndCol As Long, EndRow As Long, NextRow As Long, WebSite As String
    
    With Sheets(SheetDaten)
        EndRow = .Cells(.Rows.Count, 1).End(xlUp).Row:  NextRow = StartQuery
    
        For Each RngA In .Cells(StartDaten, 1).Resize(EndRow, 1)
            If Not IsEmpty(RngA) And Not IsEmpty(RngA.Offset(0, 1)) Then
                EndCol = .Cells(RngA.Row, .Columns.Count).End(xlToLeft).Column
                
                For Each RngX In .Cells(RngA.Row, 3).Resize(1, EndCol - 2)
                    If Not IsEmpty(RngX) Then
                        WebSite = GetUrl(WebUrl, RngA, RngA.Offset(0, 1), RngX)
                        Call QueryTableImport(Sheets(SheetQuery), WebSite, NextRow)
                        NextRow = NextRow + BreakQuery
                    End If
                Next
            End If
        Next
    End With
End Sub

Private Function GetUrl(ByRef StrUrl, ByVal Str1$, Optional ByVal Str2$, Optional ByVal Str3$, _
                  Optional ByVal Str4$, Optional ByVal Str5$, Optional ByVal Str6$) As String
    
    Dim Arg As Variant, i As Integer
    
    GetUrl = StrUrl:    Arg = Array("", Str1, Str2, Str3, Str4, Str5, Str6)  
    
    For i = 1 To 6
        GetUrl = Replace(GetUrl, "%" & (i), Arg(i))  
    Next
End Function

Private Sub QueryTableImport(ByRef Wks, ByRef WebSite, Optional ByVal Line As Long = 1)
    On Error Resume Next
    With Wks
        If Line = 1 Then .Cells.Clear
        With .QueryTables.Add(Connection:=WebSite, Destination:=.Cells(Line, 1))
            .AdjustColumnWidth = True
            .PreserveFormatting = True
            .WebSelectionType = xlSpecifiedTables
            .WebTables = "1"  
            .Refresh BackgroundQuery:=False
            .Delete
        End With
        If Err Then .Cells(Line, 1) = "Seite konnte nicht gefunden/geöffnet werden!"  
    End With
    On Error GoTo 0
End Sub

Und hier das Ergebnis:
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c20309&d=20309&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c20309&d=40525&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c20309&d=75596&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c20309&d=88900&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=10116&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=10619&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=20619&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=21656&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=21696&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c20619&d=52116&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c21082&d=21082&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c21082&d=21885&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21232&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21233&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21234&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21235&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21236&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21238&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c21232&d=21243&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c21239&d=21239&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c21239&d=21240&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=21072&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=21073&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=21074&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=21077&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=22051&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c22051&d=22178&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=20729&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=21518&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=26573&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=71307&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=71323&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26573&d=71340&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26603&d=21202&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26603&d=25445&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26603&d=25658&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c26603&d=26603&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c30899&d=30899&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c30899&d=74004&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c32590&d=32590&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=32999&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=33022&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=33081&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=33120&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=41483&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c33022&d=41891&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c33804&d=21242&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c33804&d=22331&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c33804&d=33804&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=20664&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=20907&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=21220&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=44954&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=44989&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=45021&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=50938&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=88781&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c44989&d=88803&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c50041&d=45187&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c50041&d=45209&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c50041&d=50041&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=20519&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=20914&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=30597&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=30651&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=32573&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=42595&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=42625&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=53635&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=60682&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c72893&d=60691&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c75621&d=75621&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c75621&d=75639&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c75621&d=84000&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap081vwdum.c75621&d=84001&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c99949&d=99949&srm=services
URL;http://.......&ctx=c2comsrvd.deehqap071vwdum.c99959&d=99959&srm=services

Gruß Dieter
FrageMicrosoft OfficeMicrosoft
Mehr von alsdorf2011alsdorf2011Per VBA URL aus einzelne Zellen zusammen setzenalsdorf2011 - 4 Kommentare
Heiß diskutiert
HappyHannesPing Spikes im HeimnetzHappyHannes - 32 KommentaremirdochegalServer 2025 DC - verliert nach reboot Domänenfirewallprofil - nicht als DC erreichbarmirdochegal - 31 KommentareYan2021NUC als NAS verwenden?Yan2021 - 28 KommentareMysticFoxDEWindows 11 - Unerträgliche RessourcenverschwendungMysticFoxDE - 27 Kommentaremorpheus82Lancom Router DHCP Zuweisungenmorpheus82 - 21 KommentareStefanKittelCVE am Ende?StefanKittel - 20 KommentarekpunktSuche kabelloses HID-Zeugs (Mäuse und Tastaturen)kpunkt - 20 KommentareNeurothikerMikrotik - wie ändere ich ein Interface von slave auf master?Neurothiker - 19 KommentareStefanKittelIdeen für ein zukünftiges IT-Setup für mich sammelnStefanKittel - 14 Kommentarem.sterRAM Guidem.ster - 13 KommentarejoehuabaAccessPoint Outdoor Kastenjoehuaba - 13 Kommentarelinuxer1Firmware für N7100E gesuchtlinuxer1 - 12 Kommentaregerry56Probleme mit Internetzugang für Handy im Wlangerry56 - 10 Kommentare