Veebipäringute ja ahela kasutamine 4000 andmebaasi kirje allalaadimiseks 4000 veebilehelt - Exceli näpunäited

Lang L: none (table-of-contents)

Ühel päeval sain Janilt PMA-s eetrisse e-kirja. Ta edastas suurepärase idee Gary Gagliardilt Clearbridge'i kirjastusest. Gary mainis, et mõned otsingumootorid määravad lehele lehe auastme selle põhjal, kui palju teisi saite lehele linkib. Ta soovitas, et kui kõik PMA 4000 liiget ühendaksid kõik ülejäänud 4000 PMA liiget, suurendaks see meie edetabelit. Jan pidas seda suurepäraseks ideeks ja ütles, et kõik PMA liikmete veebiaadressid on loetletud praegusel PMA veebisaidil liikmete piirkonnas.

Isiklikult arvan, et "linkide arvu" teooria on natuke müüt, kuid olin valmis seda aitama proovima.

Niisiis külastasin PMA liikmete piirkonda, kus sain kiiresti teada, et liikmete nimekirja pole olemas, vaid tegelikult on liikmete 27 nimekirja.

Külastasin PMA liikmete piirkonda.

A-lehele klõpsates nägin, et see on veelgi hullem. Iga selle lehe link ei viinud liikme veebisaidile. Iga siinne link viib PMA-online'i eraldi lehele koos liikme veebisaidiga.

Veebilehe lingid.

See tähendaks, et ma peaksin liikmete nimekirja koostamiseks külastama tuhandeid veebisaite. See oleks selgelt meeletu ettepanek.

Õnneks olen Microsoft Exceli VBA ja makrode kaasautor. Mõtlesin, kas saaksin raamatu koodi kohandada, et lahendada tuhandete lingitud lehtede liikme URL-ide väljavõtmise probleem.

Raamatu 14. peatükk räägib Exceli kasutamisest veebist lugemiseks ja veebis kirjutamiseks. Lehelt 335 leidsin koodi, mis võiks veebipäringu lennult luua.

Esimene samm oli näha, kas saan raamatu koodi kohandada nii, et oleks võimalik koostada 27 veebipäringut - üks tähestiku iga tähe ja numbri 1 jaoks. See annaks mulle mitu loendit kõigi 26 tähestikulist lehtede loendit.

Igal lehel on URL, mis sarnaneb aadressile http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Võtsin koodi lehelt 335 ja kohandasin seda natuke 27 veebipäringu tegemiseks.

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

Ülaltoodud koodis oli kohandatud neli üksust.

  • Esiteks pidin koostama õige URL-i. See saavutati URL-i stringi lõppu õige tähe lisamisega.
  • Teiseks muutsin koodi, et iga päringut käivitada töövihiku uuel töölehel.
  • Kolmandaks haaras raamatus olev kood veebilehelt 20. tabeli. Salvestades PMA-st tabelisse tõmmatava makro, sain teada, et vajan veebilehel 7. tabelit.
  • Neljandaks olin pärast makro käivitamist pettunud, kui nägin, et sain kirjastajate nimed, aga mitte hüperlinke. Raamatu kood määras .WebFormatting: = xlFormattingNone. Kasutades VBA abi, arvasin, et kui ma asendan .WebFormatting: = xlFormattingAll, saan tegelikud hüperlingid.

Pärast selle esimese makro käivitamist oli mul 27 töölehte, millest igaühel oli rida hüperlinke, mis nägi välja selline:

Ekstraheeritud lingid Exceli hüperlingitega.

Järgmine samm oli hüperlingitud aadressi väljavõtmine kõigist 27 töölehe hüperlingist. Seda pole raamatus, kuid Excelis on hüperlingi objekt. Objektil on atribuut .Address, mis tagastaks veebisaidi PMA-Online koos selle väljaandja URL-iga.

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

Pärast selle makro käivitamist sain lõpuks teada, et PMA saidil oli 4119 üksikut veebileht. Mul on hea meel, et ma ei proovinud iga üksikut saiti ükshaaval külastada!

Minu järgmine eesmärk oli ehitada veebipäring kõigi 4119 üksiku veebilehe külastamiseks. Salvestasin makro, mis tagastas ühe väljaandja lehe, et teada saada, et tahan igalt lehelt tabelit nr 5. Nägin, et kirjastaja nimi tagastati tabeli viienda reana. Enamasti tagastati veebisait 13. reana. Kuid sain teada, et mõnel juhul, kui tänava aadress oli 2 asemel 3, oli veebisaidi URL tegelikult 14. real. Kui neil oli 2 telefoni asemel 3 telefoni, lükati veebisait teisest reast alla. Makro peaks olema piisavalt paindlik, et otsida võib-olla reast 13 kuni 18, et leida veebi alustanud lahter.

Oli veel üks dilemma. Raamatu kood võimaldab veebipäringut taustal värskendada. Enamasti jälgiksin päringu lõppu tegelikult pärast makro lõppu. Minu algne mõte oli lubada igale kirjastajale 40 rida ja ehitada kõik lehed kokku 4100 päringuga. Selleks oleks vaja olnud 80 000 arvutustabeli rida ja palju mälu. Eksperimendis Excel 2002 katsetasin BackgroundRefresh'i valeks muutmist. VBA tegi head tööd, tõmmates teabe töölehele enne makro jätkamist. See võib olla päringu koostamine, päringu värskendamine, väärtuste salvestamine andmebaasi ja päringu kustutamine. Seda meetodit kasutades ei olnud töölehel korraga rohkem kui üks päring korraga.

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

Selle päringu käivitamiseks kulus rohkem kui tund. Lõppude lõpuks tegi ta tööd, külastades üle 4000 veebilehe. See jooksis tõrgeteta ja ei kukutanud arvutit ega Exceli.

Seejärel oli mul Excelis kena andmebaas, veerus A avaldaja nimi ja veerus B. Pärast veerus B veebisaidi järgi sorteerimist leidsin, et üle 1000 avaldaja ei lisanud veebisaiti. Nende kirje veerus B oli tühi URL. Sorteerisin ja kustutasin need read.

B-veerus loetletud veebisaitidel oli enne iga URL-i ka "WWW:". Kasutasin valikuid Redigeerimine> Asenda, et muuta WWW iga esinemine: (tühiku järel) tühiseks. Mul oli arvutustabelis kena nimekiri 2339 kirjastajast.

Avaldajate loend arvutustabelis.

Viimane samm oli kirjutada välja tekstifail, mida saaks kopeerida ja kleepida mis tahes liikmete veebisaidile. Järgmine makro (kohandatud koodi 345 järgi) sai selle ülesandega kenasti hakkama.

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

Tulemuseks oli tekstifail 2000+ väljaandja nime ja URL-iga.

Kõik ülaltoodud koodid olid raamatust mugandatud. Alustades tegelesin justkui ühekordse programmiga, mida ma ei kujutanud ette regulaarset käitamist. Kuid nüüd saan pildinduse iga kuu tagasi minna PMA veebisaidile, et saada ajakohastatud URL-ide loendeid.

Kõiki ülaltoodud samme oleks võimalik panna ühte makrosse.

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 ja VBA pakkusid kiire alternatiivi tuhandete veebilehtede individuaalsele külastamisele. Teoreetiliselt oleks PMA pidanud suutma oma andmebaasis päringuid teha ja seda teavet palju kiiremini esitada kui seda meetodit kasutades. Mõnikord on teil tegemist kellegagi, kes on koostöövõimetu või ei tea, kuidas andmebaasist andmeid välja saada, mille keegi teine ​​neile kirjutas. Sel juhul lahendas meie probleemi natuke VBA makrokood.

Huvitavad Artiklid...