Eräänä päivänä sain Janilta lähetyssähköpostin PMA: ssa. Hän välitti hienoa ideaa Gary Gagliardilta Clearbridge Publishingista. Gary mainitsi, että jotkut hakukoneet antavat sivulle sivutason sen perusteella, kuinka monta muuta sivustoa linkittää sivulle. Hän ehdotti, että jos kaikki PMA: n 4000 jäsentä yhdistävät kaikki PMA: n muut 4000 jäsentä, se nostaisi kaikkia sijoitustamme. Jan piti tätä hyvänä ideana ja sanoi, että kaikki PMA: n jäsenten web-osoitteet on lueteltu nykyisellä PMA-verkkosivustolla jäsenalueella.
Henkilökohtaisesti mielestäni "linkkien lukumäärä" -teoria on vähän myytti, mutta olin valmis kokeilemaan sitä auttaakseni.
Joten kävin PMA: n jäsenalueella, jossa sain nopeasti tietää, että ei ollut yhtä jäsenten luetteloa, vaan itse asiassa 27 jäsenluetteloa.
Napsauttamalla A-sivua huomasin, että se oli vielä pahempi. Jokainen tämän sivun linkki ei johtanut jäsenen verkkosivustoon. Jokainen linkki johtaa yksittäiselle sivulle PMA-verkossa jäsenen verkkosivustolla.
Tämä tarkoittaisi sitä, että minun täytyisi käydä tuhansilla verkkosivuilla jäsenten luettelon laatimiseksi. Tämä olisi selvästi mieletön ehdotus.
Onneksi olen VBA & Macros -kirjoittaja Microsoft Excelille. Mietin, voisinko mukauttaa kirjan koodin ratkaistakseni ongelman jäsenten URL-osoitteiden purkamisessa tuhansista linkitetyistä sivuista.
Kirjan luvussa 14 kerrotaan Excelin käytöstä verkosta lukemiseen ja kirjoittamiseen. Sivulta 335 löysin koodin, joka voisi luoda verkkokyselyn lennossa.
Ensimmäinen askel oli nähdä, voisinko mukauttaa kirjan koodin pystyäkseni tuottamaan 27 verkkokyselyä - yhden kullekin aakkosen kirjaimelle ja numerolle 1. Tämä antaisi minulle useita luetteloita kaikista linkeistä 26 aakkosellista sivuluetteloa.
Jokaisella sivulla on URL-osoite, joka on samanlainen kuin http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Otin koodin sivulta 335 ja räätälöin sen hieman tekemään 27 verkkokyselyä.
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 SubEdellä olevassa koodissa oli neljä mukautettua kohdetta.
- Ensin minun piti rakentaa oikea URL-osoite. Tämä saavutettiin lisäämällä oikea kirjain URL-merkkijonon loppuun.
- Toiseksi muokkain koodia suorittamaan kukin kysely työkirjan uudella laskentataulukolla.
- Kolmanneksi kirjan koodi tarttui 20. taulukosta verkkosivulta. Nauhoittamalla PMA: n taulukosta vetävän makron sain tietää, että tarvitsin verkkosivun seitsemännen taulukon.
- Neljänneksi makron suorittamisen jälkeen olin pettynyt huomatessani, että sain julkaisijoiden nimet, mutta ei hyperlinkkejä. Kirjan koodi on määritetty .WebFormatting: = xlFormattingNone. Käyttäen VBA-apua ajattelin, että jos vaihdan tiedostoon .WebFormatting: = xlFormattingAll, saisin todelliset hyperlinkit.
Tämän ensimmäisen makron suorittamisen jälkeen minulla oli 27 laskentataulukkoa, joista jokaisella oli sarja hyperlinkkejä, jotka näyttivät tältä:
Seuraava vaihe oli purkaa hyperlinkitetty osoite jokaisesta 27 laskentataulukon hyperlinkistä. Sitä ei ole kirjassa, mutta Excelissä on hyperlinkkiobjekti. Objektilla on .Address -ominaisuus, joka palauttaisi PMA-Onlinessa olevan verkkosivun kyseisen julkaisijan URL-osoitteen kanssa.
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 SubTämän makron suorittamisen jälkeen sain vihdoin tietää, että PMA-sivustolla oli 4119 yksittäistä verkkosivua. Olen iloinen siitä, etten yrittänyt käydä jokaisella sivustolla yksi kerrallaan!
Seuraava tavoitteeni oli, että rakennettaisiin verkkokysely vierailemaan jokaisella 4119 yksittäisellä verkkosivulla. Nauhoitin makron, joka palautti yhden julkaisijan sivuista saadakseen tietää, että halusin taulukon 5 jokaisesta sivusta. Huomasin, että julkaisijan nimi palautettiin taulukon viidenneksi riviksi. Useimmissa tapauksissa verkkosivusto palautettiin 13. rivinä. Kuulin kuitenkin, että joissakin tapauksissa, jos katuosoite oli 3 riviä 2 sijasta, verkkosivuston URL oli tosiasiallisesti rivillä 14. Jos heillä oli 3 puhelinta 2 sijasta, verkkosivusto työnnettiin toista riviä alaspäin. Makron on oltava riittävän joustava etsimään ehkä riveiltä 13-18 löytääkseen solu, joka aloitti WWW :.
Oli toinen ongelma. Kirjassa olevan koodin avulla verkkokysely voi päivittyä taustalla. Useimmissa tapauksissa haluaisin itse katsoa kyselyn päättymisen makron päättymisen jälkeen. Aluksi ajattelin sallia 40 riviä kustakin julkaisijasta ja rakentaa kaikki 4100 kyselyä kullekin sivulle. Tämä olisi edellyttänyt 80000 riviä laskentataulukkoa ja paljon muistia. Kokeilen Excel 2002: ssä muuttamalla BackgroundRefresh-arvon False-arvoksi. VBA teki hyvää työtä vetämällä tiedot laskentataulukkoon ennen makron jatkamista. Tämä saa olla kyselyn rakentaminen, päivittäminen, arvojen tallentaminen tietokantaan ja kyselyn poistaminen. Tätä menetelmää käyttämällä laskentataulukossa ei ollut koskaan enemmän kuin yksi kysely kerrallaan.
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 SubTämän kyselyn suorittaminen kesti yli tunnin. Loppujen lopuksi se työskenteli vierailemalla yli 4000 verkkosivulla. Se juoksi ongelmitta eikä kaatanut tietokonetta tai Exceliä.
Sitten minulla oli mukava tietokanta Excelissä, jossa Publisher-nimi sarakkeessa A ja verkkosivusto sarakkeessa B. Lajittelun verkkosivuston mukaan sarakkeessa B huomasin, että yli 1000 julkaisijaa ei listannut verkkosivustoa. Heidän merkinnänsä sarakkeeseen B oli tyhjä URL-osoite. Lajittelin ja poistin nämä rivit.
Sarakkeessa B luetelluilla verkkosivustoilla oli myös "WWW:" ennen kutakin URL-osoitetta. Käytin Muokkaa> Korvaa -toimintoa muuttaakseni jokaisen WWW: n esiintymän: (välilyönnillä sen jälkeen) tyhjäksi. Minulla oli mukava luettelo 2339 julkaisijasta laskentataulukossa.
Viimeinen vaihe oli kirjoittaa tekstitiedosto, joka voidaan kopioida ja liittää jäsenten verkkosivustoille. Seuraava makro (mukautettu koodilla sivulla 345) hoiti tämän tehtävän hienosti.
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 SubTuloksena oli tekstitiedosto, joka sisälsi vähintään 2000 julkaisijan nimen ja URL-osoitteen.
Kaikki yllä olevat koodit on mukautettu kirjasta. Kun aloitin, olin tavallaan vain tekemässä kertaluonteista ohjelmaa, jota en kuvittele käynnissä säännöllisesti. Voin kuitenkin nyt kuvankäsittelyn palata PMA-verkkosivustolle joka kuukausi saadakseni päivitetyt URL-luettelot.
Olisi mahdollista sijoittaa kaikki yllä olevat vaiheet yhteen makroon.
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 ja VBA tarjosivat nopean vaihtoehdon tuhansien verkkosivujen yksilölliselle vierailulle. Teoriassa PMA: n olisi pitänyt pystyä kyselemään tietokannastaan ja toimittamaan nämä tiedot paljon nopeammin kuin käyttämällä tätä menetelmää. Joskus olet kuitenkin tekemisissä jonkun kanssa, joka on yhteistyöhön osallistumaton tai mahdollisesti ei tiedä miten saada tietoja tietokannasta, jonka joku muu on kirjoittanut heille. Tässä tapauksessa vähän VBA-makrokoodia ratkaisi ongelmamme.
