alsdorf2011
May 22, 2011, updated at 07:26:18 (UTC)
view12145
view4
0
Goto Top

EXCEL Webabfrage per VBA Script erweitern.

GermanQuestionMicrosoft 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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 166686

Url: https://administrator.de/contentid/166686

Printed on: April 19, 2024 at 21:04 o'clock

4 Comments
Latest comment
Goto Top
Mitglied: 76109
76109 May 22, 2011 at 13:10:20 (UTC)
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
Member: alsdorf2011
alsdorf2011 May 23, 2011 at 09:23:51 (UTC)
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
Member: alsdorf2011
alsdorf2011 May 24, 2011 at 07:52:00 (UTC)
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.
Mitglied: 76109
76109 May 24, 2011 at 09:27:06 (UTC)
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
GermanQuestionMicrosoft OfficeMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsjstrickerWIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment