Visual Basic Application Dokumentation

In dieser Category werden VBA Anwendungen dokumentiert.

VBA Anwendung

VBA Anwendung GetProdDesc um aus einer Webseite mit Suchfunktion per WebQuery Daten zu importieren.

Die Aufgabenstellung ist, ein Produkt nach einer Nummer zu suchen, und dann den Produkt Titel und den Web Link auf das Produkt in ein Tabellenblatt einzutragen.

Als Eingabedaten stehen die Produkt Nummern in Spalte A ab Zeile 3. In Spalte B soll der Produkt Titel eingetragen werden, in Spalte C der Web Link auf das Produkt.

Wenn die VBA Entwicklertools im Menü nicht zu sehen ist, muss man sie erst frei schalten:

In der Tabelle1 Zelle A1 wurde eine Schaltfläche gesetzt, die mit dem Makro GetDescProd verbunden ist. Zum Starten des Programms muss man also nur auf diese Schaltfläche klicken.

Bei der Entwicklung haben geholfen, das Buch Excel programmieren, und ein Artikel von stackoverflow.com, siehe bei den Links.

VBA Listing

Hilfestellung für den Author:
Um die Liste der Pygments Lexer (syntax highlighter, z.B. vbnet) zu sehen, muss der Kommentar der folgenden Zeile im Rohtext entfernt werden. Dazu muss das Makro HighlighterList.py in moinmoin installiert sein.


Das erste Listing macht nur die Daten Verwaltung.

   1 Sub GetProdDesc()
   2     ' Get Product Description
   3     Dim strProductCode
   4     Dim Row
   5     Dim QuerySheet As Worksheet
   6     Dim DataSheet As Worksheet
   7     Set QuerySheet = Sheets("Tabelle2")
   8     Set DataSheet = Sheets("Tabelle1")
   9     Row = 3
  10     strProductCode = Cells(Row, 1)
  11     Do
  12     If IsEmpty(strProductCode) Then Exit Sub
  13         QuerySheet.Range("$A$1") = strProductCode
  14         ' Get the web data
  15         TF_Product_Number
  16         
  17         ' Copy to Tabelle1
  18         DataSheet.Select
  19         QuerySheet.Range("$B$1").Copy
  20         ActiveSheet.Cells(Row, 2).Select
  21         ActiveSheet.Paste
  22         QuerySheet.Range("$C$1").Copy
  23         ActiveSheet.Cells(Row, 3).Select
  24         ActiveSheet.Paste
  25         QuerySheet.Cells.Clear
  26         Row = Row + 1
  27         strProductCode = Cells(Row, 1)
  28     Loop
  29 End Sub

Das Programm wir nach Zeile Nummern erklärt. Das Einlesen der Web Seite und Dekodierung der Daten erfolgt im Unterprogramm TF_Product_Number() in Tabelle2.

Das zweite Listing zeigt die eigentliche Web Abfrage. Der größte Teil des VBA Programms wurde mit dem Excel Makro Recorder aufgezeichnet und dann manuell angepasst.

   1 Sub TF_Product_Number()
   2 '
   3 ' TF_Product_Number Makro
   4 ' 2015-01-10 RR
   5 '
   6     Dim strProductCode2
   7     Dim QuerySheet As Worksheet
   8     Dim DataSheet As Worksheet
   9     Set QuerySheet = Sheets("Tabelle2")
  10     Set DataSheet = Sheets("Tabelle1")
  11     
  12     ' Copy Product code to Tabelle2 for easier Test
  13     'Sheets("Tabelle1").Range("A1").Copy
  14     QuerySheet.Select
  15     Range("A1").Select
  16     'ActiveSheet.Paste
  17     strProductCode2 = Range("$A$1")
  18     'Debug.Print ProductCode
  19     
  20     With QuerySheet.QueryTables.Add(Connection:= _
  21         "URL;http://www.xxx.de/search-results.html?keyword=" & strProductCode2 & "&matchDim=Y" _
  22         , Destination:=QuerySheet.Range("$A$2"))
  23         .Name = "search-results.html?keyword=237105&matchDim=Y_1"
  24         .FieldNames = True
  25         .RowNumbers = False
  26         .FillAdjacentFormulas = False
  27         .PreserveFormatting = False
  28         .RefreshOnFileOpen = False
  29         .BackgroundQuery = True
  30         .RefreshStyle = xlInsertDeleteCells
  31         .SavePassword = False
  32         .SaveData = True
  33         .AdjustColumnWidth = True
  34         .RefreshPeriod = 0
  35         .WebSelectionType = xlEntirePage
  36         .WebFormatting = xlWebFormattingAll
  37         .WebPreFormattedTextToColumns = True
  38         .WebConsecutiveDelimitersAsOne = True
  39         .WebSingleBlockTextImport = False
  40         .WebDisableDateRecognition = False
  41         .WebDisableRedirections = False
  42         .Refresh BackgroundQuery:=False
  43     End With
  44     
  45     ' Copy Product Description and Web Link
  46     Dim ProdDesc
  47     With QuerySheet.Range("A2:A500")
  48         Set ProdDesc = .Find(What:="Sortieren nach", LookIn:=xlFormulas _
  49             , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
  50            MatchCase:=False, SearchFormat:=False)
  51         'Debug.Print "1 " & ProdDesc.Address
  52     End With
  53     If ProdDesc Is Nothing Then
  54         MsgBox "Text: 'Suchen nach' wurde nicht gefunden"
  55     Else
  56         'Debug.Print "2 " & Range(ProdDesc.Address).Offset(1, 0)
  57         Range(ProdDesc.Address).Offset(1, 0).Select
  58         Application.CutCopyMode = False
  59         Selection.Copy
  60         Range("B1").Select
  61         ' Paste Value (Product Code)) only
  62         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  63             :=False, Transpose:=False
  64         Application.CutCopyMode = False
  65         Range(ProdDesc.Address).Offset(1, 0).Select
  66         Selection.Copy
  67         Range("C1").Select
  68         ' Paste web link
  69         ActiveSheet.Paste
  70     End If
  71 End Sub

Die auskommentierten Zeilen dienen der Fehlersuche.

Liste der Seiten in dieser category:

-- RudolfReuter 2015-01-11 16:11:19


Go back to CategoryVBADoku or StartSeite ; KontaktEmail (ContactEmail)

VBADokuWebQuery (last edited 2015-01-21 13:39:30 by RudolfReuter)