Brug af webforespørgsler og en loop til at downloade 4000 databaseindgange fra 4000 websider - Excel-tip

Indholdsfortegnelse

En dag modtog jeg en udsendelses-e-mail fra Jan på PMA. Hun viderebragte en god idé fra Gary Gagliardi fra Clearbridge Publishing. Gary nævnte, at nogle søgemaskiner tildeler en siderangering til en side baseret på hvor mange andre sider der linker til siden. Han foreslog, at hvis alle 4000 medlemmer af PMA ville linke til alle 4000 andre medlemmer af PMA, ville det øge alle vores placeringer. Jan syntes dette var en god idé og sagde, at alle PMA-medlemswebadresser er angivet på det nuværende PMA-websted i medlemsområdet.

Personligt synes jeg teorien om "antal links" er lidt af en myte, men jeg var villig til at prøve det for at hjælpe.

Så jeg besøgte området PMA Members, hvor jeg hurtigt lærte, at der ikke var en enkelt liste over medlemmer, men faktisk 27 lister over medlemmer.

Jeg besøgte området PMA Members.

Da jeg klikkede igennem til "A" -siden, så jeg, at det var endnu værre. Hvert link på denne side førte ikke til medlemmets hjemmeside. Hvert link her fører til en individuel side på PMA-online med medlemmets hjemmeside.

Links på websiden.

Dette vil betyde, at jeg bliver nødt til at besøge tusinder af websider for at udarbejde listen over medlemmer. Dette ville helt klart være et vanvittigt forslag.

Heldigvis er jeg medforfatter til VBA og makroer til Microsoft Excel. Jeg spekulerede på, om jeg kunne tilpasse koden fra bogen for at løse problemet med at udtrække medlems-URL'er fra tusindvis af sammenkædede sider.

Kapitel 14 i bogen handler om at bruge Excel til at læse fra og skrive til internettet. På side 335 fandt jeg kode, der kunne skabe en webforespørgsel i farten.

Det første trin var at se, om jeg kunne tilpasse koden i bogen til at kunne producere 27 webforespørgsler - en til hver af bogstaverne i alfabetet og tallet 1. Dette ville give mig flere lister over alle links på 26 alfabetiske sidelister.

Hver side har en URL svarende til http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Jeg tog kode fra side 335 og tilpassede den lidt til 27 webforespørgsler.

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

Der var fire emner, der blev tilpasset i ovenstående kode.

  • Først måtte jeg oprette den korrekte URL. Dette blev opnået ved at tilføje det korrekte bogstav til slutningen af ​​URL-strengen.
  • For det andet ændrede jeg koden for at køre hver forespørgsel på et nyt regneark i projektmappen.
  • For det tredje tog koden i bogen den 20. tabel fra websiden. Ved at optage en makro, der trækker i tabellen fra PMA, lærte jeg, at jeg havde brug for den 7. tabel på websiden.
  • For det fjerde, efter at have kørt makroen, var jeg skuffet over at se, at jeg fik udgivernes navne, men ikke hyperlinks. Koden i den angivne bog. Webformatering: = xlFormattingNone. Ved hjælp af VBA-hjælp regnede jeg med, at hvis jeg skiftede til .WebFormatting: = xlFormattingAll, ville jeg få de faktiske hyperlinks.

Efter at have kørt denne første makro havde jeg 27 regneark, hver med en række hyperlinks, der så ud som dette:

Ekstraherede links med hyperlinks i Excel.

Det næste trin var at udtrække den hyperlinkede adresse fra hvert hyperlink på de 27 regneark. Det er ikke i bogen, men der er et hyperlinkobjekt i Excel. Objektet har en .Address-egenskab, der returnerer websiden i PMA-Online med URL'en til den pågældende udgiver.

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

Efter at have kørt denne makro lærte jeg endelig, at der var 4119 individuelle websider på PMA-webstedet. Jeg er glad for, at jeg ikke forsøgte at besøge hvert enkelt sted ad gangen!

Mit næste mål var at få en webforespørgsel bygget til at besøge hver af de 4119 individuelle websider. Jeg optog en makro, der returnerede en af ​​de enkelte forlagssider for at høre, at jeg ønskede tabel nr. 5 fra hver side. Jeg kunne se, at udgivernavnet blev returneret som den femte række i tabellen. I de fleste tilfælde blev hjemmesiden returneret som den 13. række. Imidlertid lærte jeg, at webadressen i nogle tilfælde, hvis gadeadressen var 3 linjer i stedet for 2, faktisk var på række 14. Hvis de havde 3 telefoner i stedet for 2, blev hjemmesiden skubbet ned en anden række. Makroen skulle være fleksibel nok til at søge fra måske række 13 til 18 for at finde den celle, der startede WWW :.

Der var et andet dilemma. Koden i bogen gør det muligt for webforespørgslen at opdatere i baggrunden. I de fleste tilfælde vil jeg faktisk se forespørgslen slutte, når makroen er færdig. Min oprindelige tanke var at tillade 40 rækker for hver udgiver og bygge alle 4100 forespørgsler på hver side. Dette ville have krævet 80.000 rækker regneark og meget hukommelse. I Excel 2002 eksperimenterede jeg med at ændre BackgroundRefresh til False. VBA gjorde et godt stykke arbejde med at trække informationen ind i regnearket, før makroen fortsatte. Dette kunne være at oprette forespørgslen, opdatere forespørgslen, gemme værdierne i en database og derefter slette forespørgslen. Ved hjælp af denne metode var der aldrig mere end én forespørgsel ad gangen på regnearket.

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

Det tog mere end en time at køre denne forespørgsel. Når alt kommer til alt arbejdede det med at besøge over 4000 websider. Det kørte uden problemer og styrtede ikke computeren eller Excel.

Derefter havde jeg en dejlig database i Excel med Publisher-navn i kolonne A og hjemmesiden i kolonne B. Efter at have sorteret efter websted i kolonne B, fandt jeg ud af, at over 1000 udgivere ikke opførte et websted. Deres post i kolonne B var en tom URL. Jeg sorterede og slettede disse rækker.

De websteder, der er anført i kolonne B, havde også "WWW:" før hver URL. Jeg brugte en Rediger> Udskift for at ændre hver forekomst af WWW: (med et mellemrum efter det) til ingenting. Jeg havde en god liste over 2339 udgivere på et regneark.

Forlagsliste på regnearket.

Det sidste trin var at skrive en tekstfil ud, der kunne kopieres og indsættes på ethvert medlems websted. Den følgende makro (tilpasset fra koden på side 345) håndterede denne opgave pænt.

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

Resultatet var en tekstfil med navn og URL på 2000+ udgivere.

Alle ovenstående koder blev tilpasset fra bogen. Da jeg startede, lavede jeg bare et engangsprogram, som jeg ikke forestillede mig at køre regelmæssigt. Imidlertid kan jeg nu billedbehandling gå tilbage til PMA-webstedet hver måned eller deromkring for at få de opdaterede lister over URL'er.

Det ville være muligt at placere alle ovenstående trin i en enkelt 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 Sub

Excel og VBA gav et hurtigt alternativ til individuelt at besøge tusindvis af websider. I teorien burde PMA have været i stand til at forespørge deres database og give disse oplysninger langt hurtigere end ved hjælp af denne metode. Nogle gange har du dog at gøre med nogen, der ikke er samarbejdsvillige eller muligvis ikke ved, hvordan man får data ud af en database, som en anden skrev til dem. I dette tilfælde løste en smule VBA-makro-kode vores problem.

Interessante artikler...

Anbefalet