Met behulp van webquery's en een lus om 4000 databasegegevens van 4000 webpagina's te downloaden - Excel-tips

Inhoudsopgave

Op een dag ontving ik een uitgezonden e-mail van Jan op de PMA. Ze bracht een geweldig idee door van Gary Gagliardi van Clearbridge Publishing. Gary zei dat sommige zoekmachines een paginarangschikking aan een pagina toekennen op basis van het aantal andere sites dat naar de pagina linkt. Hij suggereerde dat als alle 4000 leden van de PMA zouden linken naar alle 4000 andere leden van de PMA, dit al onze ranglijsten zou verhogen. Jan vond dit een geweldig idee en zei dat alle PMA-ledenwebadressen op de huidige PMA-website in het ledengedeelte staan.

Persoonlijk denk ik dat de "aantal links" -theorie een beetje een mythe is, maar ik was bereid om het eens te proberen om te helpen.

Dus bezocht ik het PMA-ledengedeelte, waar ik al snel ontdekte dat er niet één ledenlijst was, maar in feite 27 ledenlijsten.

Ik heb het PMA-ledengedeelte bezocht.

Toen ik doorklikte naar de "A" -pagina, zag ik dat het nog erger was. Elke link op deze pagina leidde niet naar de website van het lid. Elke link hier leidt naar een individuele pagina op PMA-online met de website van het lid.

Links op de webpagina.

Dit zou betekenen dat ik duizenden webpagina's zou moeten bezoeken om de ledenlijst samen te stellen. Dit zou duidelijk een krankzinnig voorstel zijn.

Gelukkig ben ik co-auteur van VBA & Macros voor Microsoft Excel. Ik vroeg me af of ik de code uit het boek kon aanpassen om het probleem van het extraheren van leden-URL's uit duizenden gelinkte pagina's op te lossen.

Hoofdstuk 14 van het boek gaat over het gebruik van Excel voor het lezen van en schrijven naar internet. Op pagina 335 vond ik code die on-the-fly een webquery kon maken.

De eerste stap was om te kijken of ik de code in het boek kon aanpassen om 27 webquery's te kunnen produceren - één voor elk van de letters van het alfabet en het cijfer 1. Dit zou me verschillende lijsten opleveren van alle links op de 26 alfabetische paginalijsten.

Elke pagina heeft een URL die lijkt op http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Ik nam de code van pagina 335 en paste deze een beetje aan om 27 webquery's uit te voeren.

Sub CreateNewQuery() ' Page 335 Dim WSD As Worksheet Dim WSW As Worksheet Dim QT As QueryTable For m = 1 To 27 Select Case m Case 27 MyStr = "1" Case Else MyStr = Chr(64 + m) End Select MyName = "Query" & m ConnectString = "URL;http://www.pma-online.org/scripts/showmemlist.cfm?letter=" & MyStr ThisWorkbook.Worksheets.Add ActiveSheet.Name = m ' On the Workspace worksheet, clear all existing query tables For Each QT In ActiveSheet.QueryTables QT.Delete Next QT ' Define a new Web Query Set QT = ActiveSheet.QueryTables.Add(Connection:=ConnectString, Destination:=Range("A1")) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingAll .WebTables = "7" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=True Next m End Sub

Er waren vier items die werden aangepast in de bovenstaande code.

Eerst moest ik de juiste URL bouwen. Dit werd bereikt door de juiste letter aan het einde van de URL-reeks toe te voegen.
Ten tweede heb ik de code aangepast om elke query op een nieuw werkblad in de werkmap uit te voeren.
Ten derde pakte de code in het boek de 20e tafel van de webpagina. Door een macro op te nemen die de tafel van PMA binnenhaalde, leerde ik dat ik de 7e tafel op de webpagina nodig had.
Ten vierde was ik na het draaien van de macro teleurgesteld te zien dat ik de namen van de uitgevers kreeg, maar niet de hyperlinks. De code in het boek gespecificeerd .WebFormatting: = xlFormattingNone. Met behulp van VBA-hulp dacht ik dat als ik zou veranderen naar .WebFormatting: = xlFormattingAll, ik de daadwerkelijke hyperlinks zou krijgen.

Nadat ik deze eerste macro had uitgevoerd, had ik 27 werkbladen, elk met een reeks hyperlinks die er als volgt uitzagen:

Geëxtraheerde links met hyperlinks in Excel.

De volgende stap was om het hyperlinkadres uit elke hyperlink op de 27 werkbladen te halen. Het staat niet in het boek, maar er is een hyperlinkobject in Excel. Het object heeft de eigenschap .Address die de webpagina binnen PMA-Online met de URL voor die uitgever retourneert.

Sub GetEmAll() NextRow = 1 Dim WSD As Worksheet Dim WS As Worksheet Set WSD = Worksheets("Sheet1") For Each WS In ActiveWorkbook.Worksheets If Not WS.Name = "Sheet1" Then For Each cll In WS.UsedRange.Cells For Each hl In cll.Hyperlinks WSD.Cells(NextRow, 1).Value = hl.Address NextRow = NextRow + 1 Next hl Next cll End If Next WS End Sub

Nadat ik deze macro had uitgevoerd, ontdekte ik eindelijk dat er 4119 individuele webpagina's op de PMA-site waren. Ik ben blij dat ik niet heb geprobeerd om elke afzonderlijke site een voor een te bezoeken!

Mijn volgende doel was om een webquery te laten bouwen om elk van de 4119 individuele webpagina's te bezoeken. Ik nam een macro op die een van de afzonderlijke uitgeverpagina's retourneerde om erachter te komen dat ik tabel # 5 van elke pagina wilde hebben. Ik kon zien dat de naam van de uitgever werd geretourneerd als de vijfde rij van de tabel. In de meeste gevallen werd de website geretourneerd als de 13e rij. Ik ontdekte echter dat in sommige gevallen, als het adres 3 regels was in plaats van 2, de website-URL eigenlijk op rij 14 stond. Als ze 3 telefoons hadden in plaats van 2, werd de website een andere rij naar beneden geduwd. De macro zou flexibel genoeg moeten zijn om van misschien rij 13 tot 18 te zoeken om de cel te vinden die WWW: startte.

Er was nog een dilemma. Met de code in het boek kan de webquery op de achtergrond worden vernieuwd. In de meeste gevallen zou ik de query zien eindigen nadat de macro was voltooid. Mijn eerste gedachte was om 40 rijen voor elke uitgever toe te staan en om alle 4100 zoekopdrachten op elke pagina te bouwen. Dit zou 80.000 rijen spreadsheet en veel geheugen nodig hebben gehad. In Excel 2002 heb ik geëxperimenteerd met het wijzigen van BackgroundRefresh in False. VBA heeft de informatie goed naar het werkblad getrokken voordat de macro zou doorgaan. Dit is toegestaan om de query op te bouwen, de query te vernieuwen, de waarden op te slaan in een database en vervolgens de query te verwijderen. Met deze methode was er nooit meer dan één vraag tegelijk op het werkblad.

Sub AllQuery() Dim WS As Worksheet Dim WD As Worksheet Set WD = Worksheets("database") Set WS = Worksheets("Sheet1") Dim QT As QueryTable WS.Activate OutCol = 8 OutRow = 1 FinalRow = WS.Cells(65536, 1).End(xlUp).Row For i = 2 To FinalRow ConnectString = "URL;" & WD.Cells(i, 12).Value Application.StatusBar = i ' Save after every 500 queries If i Mod 500 = 0 Then ThisWorkbook.Save End If MyName = "Query" & i ' Define a new Web Query Set QT = ActiveSheet.QueryTables.Add(Connection:=ConnectString, Destination:=WS.Cells(OutRow, OutCol)) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "5" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Change from a live query to values WS.Cells(OutRow, OutCol).Resize(40, 2).Value = WS.Cells(OutRow, OutCol).Resize(40, 2).Value For Each QT In WS.QueryTables QT.Delete Next QT ' Copy to Database WD.Cells(i, 1).Value = WS.Cells(5, 8).Value For j = 13 To 20 CheckIt = WS.Cells(j, 8).Value If Left(CheckIt, 3) = "WWW" Then WD.Cells(i, 8).Value = CheckIt End If Next j Next i End Sub

Het uitvoeren van deze zoekopdracht duurde meer dan een uur. Het deed tenslotte het werk van het bezoeken van meer dan 4000 webpagina's. Het werkte probleemloos en de computer of Excel crashte niet.

Ik had toen een mooie database in Excel met uitgeversnaam in kolom A en de website in kolom B. Na het sorteren op website in kolom B ontdekte ik dat meer dan 1000 uitgevers geen website vermeldden. Hun vermelding in kolom B was een lege URL. Ik heb deze rijen gesorteerd en verwijderd.

Ook hadden de websites in kolom B "WWW:" voor elke URL. Ik heb Bewerken> Vervangen gebruikt om elk voorkomen van WWW: (met een spatie erachter) in niets te veranderen. Ik had een mooie lijst van 2339 uitgevers op een spreadsheet.

Lijst van uitgevers op de spreadsheet.

De laatste stap was het schrijven van een tekstbestand dat kon worden gekopieerd en geplakt op de website van een lid. De volgende macro (aangepast van de code op pagina 345) heeft deze taak keurig afgehandeld.

Sub WriteHTML() On Error Resume Next Kill "C:PMALinks.txt" On Error GoTo 0 Open "C:PMALinks.txt" For Output As #1 Print #1, "Visit the websites of our fellow PMA members:

" For i = 2 To 2340 MyStr = "
" & Cells(i, 1).Value & "" Print #1, MyStr Next i Print #1, "

" Close #1 End Sub

Het resultaat was een tekstbestand met de naam en URL van 2000+ uitgevers.

Alle bovenstaande code is overgenomen uit het boek. Toen ik begon, deed ik gewoon een eenmalig programma waarvan ik niet had verwacht dat het regelmatig zou draaien. Ik kan nu echter elke maand teruggaan naar de PMA-website om de bijgewerkte lijsten met URL's te krijgen.

Het zou mogelijk zijn om alle bovenstaande stappen in één macro te stoppen.

Sub DoEverything() Dim WSW As Worksheet Dim WST As Worksheet Set WSW = Worksheets("Workspace") Set WST = Worksheets("Template") On Error Resume Next Kill "C:AutoLinks.txt" On Error GoTo 0 Open "C:PMALinks.txt" For Output As #1 Print #1, "Visit the websites of our fellow PMA members:

" For m = 1 To 27 Select Case m Case 27 MyStr = "1" Case Else MyStr = Chr(64 + m) End Select MyName = "Query" & m ConnectString = "URL;http://www.pma-online.org/scripts/showmemlist.cfm?letter=" & MyStr ' On the Workspace worksheet, clear all existing query tables For Each QT In WSW.QueryTables QT.Delete Next QT ' Define a new Web Query Set QT = WSW.QueryTables.Add(Connection:=ConnectString, Destination:=WSW.Range("A1")) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingAll .WebTables = "7" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Next, loop through all of the hyperlinks in the resulting page For Each cll In WSW.UsedRange.Cells For Each hl In cll.Hyperlinks MyURL = hl.Address ' Build a web query on WST ConnectString = "URL;" & MyURL MyName = "Query" & NextRow ' Define a new Web Query Set QT = WST.QueryTables.Add(Connection:=ConnectString, Destination:=WST.Cells(1, 1)) With QT .Name = MyName .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = False .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "5" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False End With ' Refresh the Query QT.Refresh BackgroundQuery:=False ' Change from a live query to values WST.Cells(1, 1).Resize(40, 2).Value = WST.Cells(1, 1).Resize(40, 2).Value For Each QT In WS.QueryTables QT.Delete Next QT ' Find URL ThisPub = WS.Cells(5, 8).Value ThisURL = "WWW: http://" For j = 13 To 20 CheckIt = WS.Cells(j, 8).Value If Left(CheckIt, 3) = "WWW" Then ThisURL = CheckIt End If Next j If Not ThisURL = "WWW: http://" Then ' write a record to the .txt file MyStr = "
" & ThisPub & "" Print #1, MyStr End If Next hl Next cll Next m Print #1, "

" Close #1 End Sub

Excel en VBA boden een snel alternatief voor het individueel bezoeken van duizenden webpagina's. In theorie had de PMA in staat moeten zijn om hun database te doorzoeken en deze informatie veel sneller te verstrekken dan met deze methode. Soms hebt u echter te maken met iemand die niet meewerkt of mogelijk niet weet hoe hij gegevens uit een database moet halen die iemand anders voor hem heeft geschreven. In dit geval loste een beetje VBA-macrocode ons probleem op.