Používanie webových dotazov a slučky na stiahnutie 4 000 záznamov z 4 000 webových stránok - tipy v programe Excel

Obsah

Jedného dňa som dostal vysielaný e-mail od Jana v PMA. Predávala skvelý nápad od Garyho Gagliardiho z vydavateľstva Clearbridge Publishing. Gary spomenul, že niektoré vyhľadávače priraďujú stránke hodnotenie stránky podľa toho, koľko ďalších webov na stránku odkazuje. Naznačoval, že ak by sa všetkých 4000 členov PMA prepojilo na všetkých 4000 ďalších členov PMA, zvýšilo by to všetky naše hodnotenie. Jan to považoval za vynikajúci nápad a uviedol, že všetky webové adresy členov PMA sú uvedené na aktuálnom webe PMA v oblasti členov.

Osobne si myslím, že teória „počtu odkazov“ je trochu mýtus, ale bol som ochotný to vyskúšať a pomôcť.

Navštívil som teda oblasť PMA Members, kde som sa rýchlo dozvedel, že neexistuje jediný zoznam členov, ale v skutočnosti 27 zoznamov členov.

Navštívil som oblasť členov PMA.

Keď som sa preklikal na stránku „A“, uvidel som, že to bolo ešte horšie. Každý odkaz na tejto stránke neviedol na web člena. Každý odkaz tu vedie na samostatnú stránku na PMA-online s webovou stránkou člena.

Odkazy na webovej stránke.

To by znamenalo, že by som musel navštíviť tisíce webových stránok, aby som mohol zostaviť zoznam členov. To by zjavne bol šialený návrh.

Našťastie som spoluautorom VBA a makier pre Microsoft Excel. Zaujímalo ma, či by som mohol prispôsobiť kód z knihy tak, aby vyriešil problém s extrahovaním členských adries z tisícov prepojených stránok.

Kapitola 14 knihy je o používaní programu Excel na čítanie a zápis na web. Na strane 335 som našiel kód, ktorý dokáže vytvoriť webový dopyt za behu.

Prvým krokom bolo zistiť, či dokážem prispôsobiť kód v knihe tak, aby bol schopný vytvoriť 27 webových dotazov - jeden pre každé z písmen abecedy a číslo 1. Takto by som získal niekoľko zoznamov všetkých odkazov na 26 abecedných zoznamov stránok.

Každá stránka má adresu URL podobnú adrese http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Vzal som kód zo stránky 335 a trochu som ho upravil na vykonanie 27 webových dotazov.

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

Vo vyššie uvedenom kóde boli upravené štyri položky.

  • Najskôr som musel vytvoriť správnu adresu URL. To sa dosiahlo pripojením správneho písmena na koniec reťazca URL.
  • Po druhé, upravil som kód tak, aby sa každý dotaz spustil v novom zošite v zošite.
  • Po tretie, kód v knihe chytil 20. tabuľku z webovej stránky. Nahraním makra naťahujúceho tabuľku z PMA som sa dozvedel, že potrebujem 7. tabuľku na webovej stránke.
  • Po štvrté, po spustení makra som bol sklamaný, že som dostal mená vydavateľov, ale nie hypertextové odkazy. Kód v knihe uviedol .WebFormatting: = xlFormattingNone. Pomocou pomoci VBA som si myslel, že ak by som zmenil na .WebFormatting: = xlFormattingAll, dostal by som skutočné hypertextové odkazy.

Po spustení tohto prvého makra som mal 27 pracovných listov, každý so sériou hypertextových odkazov, ktoré vyzerali takto:

Extrahované odkazy s hypertextovými odkazmi v programe Excel.

Ďalším krokom bola extrakcia adresy s hypertextovým odkazom z každého hypertextového odkazu na 27 pracovných hárkoch. Nie je to v knihe, ale v programe Excel je objekt hypertextového odkazu. Objekt má vlastnosť .Address, ktorá by vrátila webovú stránku v rámci PMA-Online s adresou URL daného vydavateľa.

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

Po spustení tohto makra som sa konečne dozvedel, že na webe PMA bolo 4119 samostatných webových stránok. Som rád, že som sa nepokúšal navštíviť jednotlivé stránky po jednom!

Mojím ďalším cieľom bolo nechať si vytvoriť webový dopyt, ktorý navštívi každú zo 4119 jednotlivých webových stránok. Zaznamenal som makro vracajúce jednu z jednotlivých stránok vydavateľa, aby som sa dozvedel, že chcem tabuľku č. 5 z každej stránky. Videl som, že meno vydavateľa bolo vrátené ako piaty riadok tabuľky. Vo väčšine prípadov sa web vrátil ako 13. riadok. Dozvedel som sa však, že v niektorých prípadoch, ak mala ulica 3 riadky namiesto 2, bola adresa URL webových stránok skutočne v riadku 14. Ak mali namiesto dvoch telefónov 3 telefóny, bola webová stránka posunutá o ďalší riadok nadol. Makro by muselo byť dostatočne flexibilné, aby mohlo vyhľadávať snáď od 13. do 18. riadku, aby bolo možné nájsť bunku, ktorá spustila WWW :.

Nastala ďalšia dilema. Kód v knihe umožňuje, aby sa webový dopyt obnovil na pozadí. Vo väčšine prípadov by som vlastne sledoval dokončenie dotazu po dokončení makra. Moja prvotná myšlienka bola umožniť 40 riadkov pre každého vydavateľa a vytvoriť všetkých 4 400 dotazov na každej stránke. To by vyžadovalo 80 000 riadkov tabuľky a veľa pamäte. V programe Excel 2002 som experimentoval so zmenou BackgroundRefresh na False. VBA odviedla dobrú prácu, keď stiahla informácie do hárka skôr, ako makro pokračovalo. To umožnilo vytvoriť dotaz, aktualizovať dotaz, uložiť hodnoty do databázy a potom dotaz vymazať. Pri použití tejto metódy v pracovnom hárku nikdy nebol viac ako jeden dopyt.

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

Spustenie tohto dotazu trvalo viac ako hodinu. Koniec koncov, robila prácu na návšteve viac ako 4 000 webových stránok. Fungovalo to bez problémov a nezrazilo sa v ňom počítač ani program Excel.

Potom som mal v programe Excel peknú databázu s menom vydavateľa v stĺpci A a webom v stĺpci B. Po zoradení podľa webu v stĺpci B som zistil, že viac ako 1 000 vydavateľov neuviedlo zoznam webových stránok. Ich položka v stĺpci B bola prázdna adresa URL. Tieto riadky som zoradil a vymazal.

Webové stránky uvedené v stĺpci B mali tiež pred každou adresou URL „WWW:“. Použil som príkaz Upraviť> Nahradiť na zmenu každého výskytu WWW: (s medzerou za ním) na nič. V tabuľke som mal pekný zoznam 2339 vydavateľov.

Zoznam vydavateľov v tabuľke.

Posledným krokom bolo napísanie textového súboru, ktorý bolo možné skopírovať a vložiť na webovú stránku ľubovoľného člena. Nasledujúce makro (upravené z kódu na strane 345) túto úlohu zvládlo pekne.

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

Výsledkom bol textový súbor s názvom a adresou URL viac ako 2 000 vydavateľov.

Celý vyššie uvedený kód bol adaptovaný z knihy. Keď som začínal, robil som akoby len jednorazový program, ktorý som si nepredstavoval pravidelne. Teraz však môžem zobrazovať obrázky tak, že sa každý mesiac vrátim na webovú stránku PMA, aby som získal aktualizované zoznamy adries URL.

Bolo by možné dať všetky vyššie uvedené kroky do jedného makra.

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 a VBA poskytli rýchlu alternatívu k individuálnej návšteve tisícov webových stránok. Teoreticky mala byť PMA schopná vyhľadávať v ich databáze a poskytovať tieto informácie oveľa rýchlejšie ako pri použití tejto metódy. Niekedy však máte do činenia s niekým, kto nespolupracuje alebo možno nevie, ako získať údaje z databázy, ktorú pre nich napísal niekto iný. V tomto prípade náš problém vyriešil kúsok kódu makra VBA.

Zaujímavé články...