Bruke nettspørringer og en sløyfe for å laste ned 4000 databaseoppføringer fra 4000 websider - Excel-tips

Innholdsfortegnelse

En dag mottok jeg en kringkastings-e-post fra Jan på PMA. Hun ga en god idé fra Gary Gagliardi fra Clearbridge Publishing. Gary nevnte at noen søkemotorer tilordner en siderangering til en side basert på hvor mange andre nettsteder som lenker til siden. Han antydet at hvis alle 4000 medlemmer av PMA ville koble til alle 4000 andre medlemmer av PMA, ville det øke alle våre rangeringer. Jan syntes dette var en god idé og sa at alle nettadressene til PMA-medlemmene er oppført på det nåværende PMA-nettstedet i medlemsområdet.

Personlig synes jeg "antall lenker" -teorien er litt av en myte, men jeg var villig til å prøve den for å hjelpe.

Så jeg besøkte PMA Members-området, hvor jeg raskt lærte at det ikke var en eneste liste over medlemmer, men faktisk 27 lister over medlemmer.

Jeg besøkte PMA Members-området.

Da jeg klikket meg gjennom til "A" -siden, så jeg at den var enda verre. Hver lenke på denne siden førte ikke til medlemmets nettsted. Hver lenke her fører til en individuell side på PMA-online med medlemmets nettsted.

Lenker på websiden.

Dette vil bety at jeg må besøke tusenvis av nettsider for å lage en liste over medlemmer. Dette vil helt klart være en sinnssyk proposisjon.

Heldigvis er jeg medforfatter av VBA og makroer for Microsoft Excel. Jeg lurte på om jeg kunne tilpasse koden fra boken for å løse problemet med å trekke ut medlems-URL-er fra tusenvis av koblede sider.

Kapittel 14 i boka handler om å bruke Excel til å lese fra og skrive til nettet. På side 335 fant jeg kode som kunne lage en nettsøking på farten.

Det første trinnet var å se om jeg kunne tilpasse koden i boka for å kunne produsere 27 nettspørsmål - en for hver av bokstavene i alfabetet og tallet 1. Dette vil gi meg flere lister over alle lenkene på 26 alfabetiske sidelister.

Hver side har en URL som ligner http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Jeg tok kode fra side 335 og tilpasset den litt for å gjøre 27 nettspørsmål.

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

Det var fire elementer som ble tilpasset i ovennevnte kode.

  • Først måtte jeg bygge riktig URL. Dette ble oppnådd ved å legge til riktig bokstav til slutten av URL-strengen.
  • For det andre endret jeg koden for å kjøre hvert spørsmål på et nytt regneark i arbeidsboken.
  • For det tredje tok koden i boken den 20. tabellen fra websiden. Ved å registrere en makro som trekker inn tabellen fra PMA, lærte jeg at jeg trengte den 7. tabellen på websiden.
  • For det fjerde, etter å ha kjørt makroen, var jeg skuffet over å se at jeg fikk navnene på utgiverne, men ikke hyperkoblingene. Koden i boken angitt. Webformatering: = xlFormattingNone. Ved hjelp av VBA-hjelp skjønte jeg at hvis jeg endret til .WebFormatting: = xlFormattingAll, ville jeg få de faktiske hyperkoblingene.

Etter å ha kjørt denne første makroen hadde jeg 27 regneark, hver med en serie hyperkoblinger som så slik ut:

Ekstraherte lenker med hyperkoblinger i Excel.

Det neste trinnet var å trekke ut den hyperkoblede adressen fra hver hyperkobling på de 27 regnearkene. Det står ikke i boka, men det er et hyperkoblingsobjekt i Excel. Objektet har en .Address-egenskap som returnerer websiden i PMA-Online med URL-adressen til den utgiveren.

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

Etter å ha kjørt denne makroen, fikk jeg endelig vite at det var 4119 individuelle nettsider på PMA-nettstedet. Jeg er glad for at jeg ikke prøvde å besøke hvert enkelt nettsted om gangen!

Mitt neste mål var å få laget en nettsøking for å besøke hver av de 4119 individuelle nettsidene. Jeg spilte inn en makro som returnerte en av de enkelte forlagssidene for å høre at jeg ønsket tabell 5 fra hver side. Jeg kunne se at forleggernavnet ble returnert som den femte raden i tabellen. I de fleste tilfeller ble nettstedet returnert som 13. rad. Imidlertid lærte jeg at i noen tilfeller, hvis gateadressen var 3 linjer i stedet for 2, var nettadressen faktisk på rad 14. Hvis de hadde 3 telefoner i stedet for 2, ble nettstedet presset ned en annen rad. Makroen måtte være fleksibel nok til å søke fra rad 13 til 18 for å finne cellen som startet WWW :.

Det var et annet dilemma. Koden i boken gjør at nettsøket kan oppdateres i bakgrunnen. I de fleste tilfeller vil jeg faktisk se spørringen avsluttes etter at makroen er ferdig. Min første tanke var å tillate 40 rader for hver utgiver, og å bygge alle 4100 spørsmål på hver side. Dette ville ha krevd 80 000 rader med regneark og mye minne. I Excel 2002 eksperimenterte jeg med å endre BackgroundRefresh til False. VBA gjorde en god jobb med å hente informasjonen inn i regnearket før makroen fortsatte. Dette kan være å bygge spørringen, oppdatere spørringen, lagre verdiene i en database og deretter slette spørringen. Ved å bruke denne metoden var det aldri mer enn ett spørsmål om 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

Dette spørsmålet tok mer enn en time å kjøre. Tross alt gjorde det arbeidet med å besøke over 4000 websider. Det kjørte uten problemer og krasjet ikke datamaskinen eller Excel.

Jeg hadde en fin database i Excel med Publisher-navn i kolonne A og nettstedet i kolonne B. Etter å ha sortert etter nettsted i kolonne B, fant jeg ut at over 1000 utgivere ikke oppførte et nettsted. Deres oppføring i kolonne B var en tom URL. Jeg sorterte og slettet disse radene.

Nettstedene oppført i kolonne B hadde også "WWW:" før hver URL. Jeg brukte en Rediger> Erstatt for å endre hver forekomst av WWW: (med et mellomrom etter) til ingenting. Jeg hadde en fin liste over 2339 utgivere på et regneark.

Forlagsliste på regnearket.

Det siste trinnet var å skrive ut en tekstfil som kunne kopieres og limes inn på medlemmets nettsted. Følgende makro (tilpasset fra koden på side 345) taklet denne oppgaven pent.

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 ble en tekstfil med navn og URL til 2000+ utgivere.

All ovennevnte kode ble tilpasset fra boka. Da jeg startet, gjorde jeg liksom bare et engangsprogram som jeg ikke så for meg å kjøre regelmessig. Imidlertid kan jeg nå ta bilder tilbake til PMA-nettstedet hver måned eller så for å få oppdaterte lister over URL-er.

Det ville være mulig å sette alle trinnene ovenfor 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 ga et raskt alternativ til individuelt å besøke tusenvis av websider. I teorien burde PMA ha vært i stand til å spørre databasen sin og gi denne informasjonen mye raskere enn å bruke denne metoden. Noen ganger har du imidlertid å gjøre med noen som ikke er samarbeidsvillige eller muligens ikke vet hvordan du skal få data ut av en database som noen andre skrev for dem. I dette tilfellet løste litt VBA-makrokode problemet vårt.

Interessante artikler...