Utilizarea interogărilor web și a unei bucle pentru a descărca 4000 de intrări de baze de date din 4000 de pagini web - Sfaturi Excel

Cuprins

Într-o zi, am primit un e-mail difuzat de la Jan la PMA. Trecea de-a lungul unei idei grozave de la Gary Gagliardi de la Clearbridge Publishing. Gary a menționat că unele motoare de căutare atribuie un rang de pagină unei pagini în funcție de câte alte site-uri conectează la pagină. El a sugerat că, dacă toți cei 4000 de membri ai PMA ar face legătura cu toți ceilalți 4000 de membri ai PMA, aceasta ar spori toate clasamentele noastre. Jan a crezut că aceasta este o idee grozavă și a spus că toate adresele web ale membrilor PMA sunt listate pe site-ul web actual al PMA din zona membrilor.

Personal, cred că teoria „numărului de link-uri” este un pic mit, dar am fost dispus să încerc asta pentru a ajuta.

Așadar, am vizitat zona membrilor PMA, unde am aflat rapid că nu există o singură listă de membri, ci de fapt 27 de liste de membri.

Am vizitat zona membrilor PMA.

Când am dat clic pe pagina „A”, am văzut că era și mai rău. Fiecare link de pe această pagină nu a condus la site-ul web al membrului. Fiecare link de aici duce la o pagină individuală la PMA-online cu site-ul web al membrului.

Linkuri în pagina web.

Acest lucru ar însemna că ar trebui să vizitez mii de pagini web pentru a compila lista membrilor. Aceasta ar fi în mod clar o propunere nebună.

Din fericire, sunt co-autorul VBA & Macros pentru Microsoft Excel. M-am întrebat dacă aș putea personaliza codul din carte pentru a rezolva problema extragerii URL-urilor membrilor din mii de pagini conectate.

Capitolul 14 al cărții este despre utilizarea Excel pentru citirea și scrierea pe web. La pagina 335, am găsit cod care ar putea crea o interogare web din mers.

Primul pas a fost să văd dacă aș putea personaliza codul din carte pentru a putea produce 27 de interogări web - una pentru fiecare dintre literele alfabetului și numărul 1. Acest lucru mi-ar oferi mai multe liste cu toate linkurile de pe 26 listări de pagini alfabetice.

Fiecare pagină are o adresă URL similară cu http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Am luat codul de la pagina 335 și l-am personalizat puțin pentru a face 27 de interogări web.

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

Au fost patru elemente care au fost personalizate în codul de mai sus.

Mai întâi, a trebuit să construiesc adresa URL corectă. Acest lucru a fost realizat prin adăugarea literei corespunzătoare la sfârșitul șirului URL.
În al doilea rând, am modificat codul pentru a rula fiecare interogare pe o nouă foaie de lucru din registrul de lucru.
În al treilea rând, codul din carte scotea a 20-a masă de pe pagina web. Înregistrând un macro care trage în tabel de la PMA, am aflat că aveam nevoie de al 7-lea tabel pe pagina web.
În al patrulea rând, după ce am rulat macro-ul, am fost dezamăgit să văd că primesc numele editorilor, dar nu și hyperlinkurile. Codul din carte a specificat .WebFormatting: = xlFormattingNone. Folosind ajutorul VBA, m-am gândit că, dacă m-aș schimba în .WebFormatting: = xlFormattingAll, aș obține hyperlinkurile reale.

După ce am rulat această primă macro, am avut 27 de foi de lucru, fiecare cu o serie de hyperlinkuri care arătau astfel:

Linkuri extrase cu hyperlinkuri în Excel.

Următorul pas a fost extragerea adresei hyperlink din fiecare hyperlink din cele 27 de foi de lucru. Nu este în carte, dar există un obiect hyperlink în Excel. Obiectul are o proprietate .Address care ar returna pagina web în cadrul PMA-Online cu adresa URL a acelui editor.

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

După ce am rulat această macro, am aflat în cele din urmă că există 4119 de pagini web individuale pe site-ul PMA. Mă bucur că nu am încercat să vizitez fiecare site individual câte unul!

Următorul meu obiectiv a fost să creez o interogare web pentru a vizita fiecare dintre cele 4119 de pagini web individuale. Am înregistrat un macro care returnează una dintre paginile individuale ale editorului pentru a afla că doresc tabelul nr. 5 din fiecare pagină. Am putut vedea că numele editorului a fost returnat ca al cincilea rând al tabelului. În majoritatea cazurilor, site-ul a fost returnat ca al 13-lea rând. Cu toate acestea, am aflat că, în unele cazuri, dacă adresa străzii era de 3 linii în loc de 2, adresa URL a site-ului se afla de fapt pe rândul 14. Dacă aveau 3 telefoane în loc de 2, site-ul web era împins în jos pe un alt rând. Macro-ul ar trebui să fie suficient de flexibil pentru a căuta de la rândul 13 la 18, pentru a găsi celula care a pornit WWW :.

A existat o altă dilemă. Codul din carte permite interogării web să se actualizeze în fundal. În cele mai multe cazuri, aș urmări efectiv interogarea după terminarea macro-ului. Gândul meu inițial a fost să permit 40 de rânduri pentru fiecare editor și să creez toate cele 4100 de interogări pe fiecare pagină. Acest lucru ar fi necesitat 80.000 de rânduri de foi de calcul și multă memorie. În Excel 2002, am experimentat schimbarea BackgroundRefresh la False. VBA a făcut o treabă bună de a trage informațiile în foaia de lucru înainte ca macro-ul să continue. Acest lucru permis este să construiți interogarea, să reîmprospătați interogarea, să salvați valorile într-o bază de date, apoi să ștergeți interogarea. Folosind această metodă, nu a existat niciodată mai mult de o interogare odată pe foaia de lucru.

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

Această interogare a durat mai mult de o oră. La urma urmei, făcea munca de a vizita peste 4000 de pagini web. A funcționat fără probleme și nu a blocat computerul sau Excel.

Am avut apoi o bază de date frumoasă în Excel cu numele editorului în coloana A și site-ul web în coloana B. După ce am sortat în funcție de site-ul web în coloana B, am constatat că peste 1000 de editori nu au listat un site web. Intrarea lor în coloana B era o adresă URL goală. Am sortat și șters aceste rânduri.

De asemenea, site-urile listate în coloana B aveau „WWW:” înainte de fiecare adresă URL. Am folosit un Editare> Înlocuire pentru a schimba fiecare apariție a WWW: (cu un spațiu după el) în nimic. Am avut o listă frumoasă de 2339 de editori pe o foaie de calcul.

Lista editorilor din foaia de calcul.

The last step was to write out a text file that could be copied and pasted into any members' website. The following macro (adapted from the code on page 345) handled this task nicely.

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

The result was a text file with the name and URL of 2000+ publishers.

All of the above code was adapted from the book. When I started, I was sort of just doing a one-off program that I didn't envision running regularly. However, I can now imaging going back to the PMA website every month or so to get the updated lists of URL's.

It would be possible to put all of the above steps into a single macro.

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 and VBA provided a quick alternative to individually visiting thousands of web pages. In theory, the PMA should have been able to query their database and provide this information far more quickly than using this method. However, sometimes you are dealing with someone who is uncooperative or possibly doesn't know how to get data out of a database that someone else wrote for them. In this case, a bit of VBA macro code solved our problem.