Nekega dne sem na PMA prejel elektronsko sporočilo od Jana. Prenašala je odlično idejo Garyja Gagliardija iz založbe Clearbridge. Gary je omenil, da nekateri iskalniki strani dodelijo uvrstitev strani glede na to, koliko drugih spletnih strani vodi do strani. Predlagal je, da če bi se vseh 4000 članov PMA povezalo z vsemi 4000 drugimi člani PMA, bi to povečalo našo uvrstitev. Jan se je zdel to dobra ideja in dejal, da so vsi spletni naslovi članov PMA navedeni na trenutni spletni strani PMA na območju za člane.
Osebno mislim, da je teorija "števila povezav" mit, vendar sem bila pripravljena poskusiti, da bi pomagala.
Tako sem obiskal območje članov PMA, kjer sem hitro ugotovil, da ni enotnega seznama članov, ampak dejansko 27 seznamov članov.
Ko sem kliknil na stran »A«, sem videl, da je še slabše. Vsaka povezava na tej strani ni vodila do spletnega mesta člana. Vsaka povezava tukaj vodi do posamezne strani na PMA-online s spletnim mestom člana.
To bi pomenilo, da bi moral obiskati tisoče spletnih strani, da bi sestavil seznam članov. To bi bilo očitno noro.
Na srečo sem soavtor VBA in makrov za Microsoft Excel. Spraševal sem se, ali bi lahko prilagodil kodo iz knjige, da bi rešil težavo pri pridobivanju URL-jev članov s tisoč povezanih strani.
14. poglavje knjige govori o uporabi Excela za branje in pisanje v splet. Na strani 335 sem našel kodo, ki bi lahko sproti ustvarila spletno poizvedbo.
Prvi korak je bil preveriti, ali lahko prilagodim kodo v knjigi, da lahko ustvarim 27 spletnih poizvedb - po eno za vsako črko abecede in številko 1. To bi mi dalo več seznamov vseh povezav na 26 abecednih seznamov strani.
Vsaka stran ima URL, podoben http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Kodo sem vzel s strani 335 in jo nekoliko prilagodil za 27 spletnih poizvedb.
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 SubV zgornji kodi so bili prilagojeni štirje elementi.
- Najprej sem moral zgraditi pravilen URL. To je bilo doseženo z dodajanjem ustrezne črke na konec niza URL.
- Drugič, kodo sem spremenil tako, da je vsako poizvedbo zagnal na novem delovnem listu v delovnem zvezku.
- Tretjič, koda v knjigi je s spletne strani grabila 20. tabelo. S snemanjem makra, ki vleče v tabelo iz PMA, sem izvedel, da potrebujem 7. tabelo na spletni strani.
- Četrtič, po zagonu makra sem bil razočaran, ko sem videl, da sem dobil imena založnikov, ne pa tudi hiperpovezav. Koda v knjigi je navedena .WebFormatting: = xlFormattingNone. S pomočjo VBA sem ugotovil, da bi, če bi se spremenil v .WebFormatting: = xlFormattingAll, dobil dejanske hiperpovezave.
Po zagonu tega prvega makra sem imel 27 delovnih listov, vsak z vrsto hiperpovezav, ki so bile videti takole:
Naslednji korak je bil izvleči hiperpovezani naslov iz vsake hiperpovezave na 27 delovnih listih. V knjigi je ni, v Excelu pa obstaja objekt hiperpovezave. Objekt ima lastnost .Address, ki vrne spletno stran znotraj PMA-Online z URL-jem tega založnika.
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 SubPo zagonu tega makra sem končno izvedel, da je na spletnem mestu PMA 4119 posameznih spletnih strani. Vesel sem, da nisem poskušal obiskati vsakega posameznega spletnega mesta posebej!
Moj naslednji cilj je bil izdelati spletno poizvedbo za obisk vsake od 4119 posameznih spletnih strani. Posnel sem makro, ki je vrnil eno od posameznih strani založnika, da sem izvedel, da želim tabelo št. 5 z vsake strani. Videl sem, da je bilo ime založnika vrnjeno kot peta vrstica tabele. V večini primerov je bilo spletno mesto vrnjeno kot 13. vrstica. Vendar sem izvedel, da je bil v nekaterih primerih, če je bil naslov ulice 3 vrstici namesto 2, URL spletnega mesta dejansko v vrstici 14. Če so imeli tri telefone namesto 2, je bilo spletno mesto potisnjeno za drugo vrstico navzdol. Makro bi moral biti dovolj prilagodljiv za iskanje od morda do vrstice 13 do 18, da bi našli celico, ki je začela WWW :.
Bila je še ena dilema. Koda v knjigi omogoča, da se spletna poizvedba osveži v ozadju. V večini primerov bi dejansko gledal zaključek poizvedbe po končanem makru. Moja prvotna misel je bila omogočiti 40 vrstic za vsakega založnika in zgraditi vseh 4100 poizvedb na vsaki strani. To bi zahtevalo 80.000 vrstic preglednice in veliko pomnilnika. V Excelu 2002 sem eksperimentiral s spreminjanjem BackgroundRefresh na False. VBA je dobro potegnil informacije na delovni list, preden se makro nadaljuje. To je dovoljeno graditi poizvedbo, osvežiti poizvedbo, shraniti vrednosti v bazo podatkov in nato poizvedbo izbrisati. S to metodo na delovnem listu ni bilo nikoli več poizvedb hkrati.
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 SubIzvajanje te poizvedbe je trajalo več kot eno uro. Navsezadnje je opravljal obisk več kot 4000 spletnih strani. Delal je brez težav in ni zrušil računalnika ali Excela.
Nato sem imel lepo zbirko podatkov v Excelu z imenom založnika v stolpcu A in spletno stran v stolpcu B. Po razvrščanju po spletnih mestih v stolpcu B sem ugotovil, da več kot 1000 založnikov ni navedlo spletnega mesta. Njihov vnos v stolpec B je bil prazen URL. Te vrstice sem razvrstil in izbrisal.
Tudi spletna mesta, navedena v stolpcu B, so imela pred vsakim URL-jem "WWW:". Uporabil sem Uredi> Zamenjaj, da sem vsako pojavitev WWW: (s presledkom) spremenil v nič. V preglednici sem imel lep seznam 2339 založnikov.
Zadnji korak je bil izpis besedilne datoteke, ki bi jo lahko kopirali in prilepili na spletno mesto katerega koli člana. Naslednji makro (prilagojen kodi na strani 345) je to nalogo lepo obvladal.
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 SubRezultat je bila besedilna datoteka z imenom in URL-jem več kot 2000 založnikov.
Vsa zgornja koda je bila prilagojena knjigi. Ko sem začel, sem nekako samo izvajal enkratni program, ki si ga nisem predstavljal redno izvajati. Vendar lahko zdaj slikam, da se vsak mesec vrnem na spletno mesto PMA, da dobim posodobljene sezname URL-jev.
Vse zgornje korake bi bilo mogoče združiti v en makro.
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 SubExcel in VBA sta bila hitra alternativa individualnemu obisku na tisoče spletnih strani. Teoretično bi moral PMA biti sposoben poizvedovati po njihovi zbirki podatkov in te informacije posredovati veliko hitreje kot s to metodo. Vendar včasih imate opravka z nekom, ki ne sodeluje ali morda ne ve, kako iz baze podatkov pridobiti podatke, ki jih je nekdo drug napisal zanje. V tem primeru je nekaj kode makra VBA rešilo naš problem.
