Använda webbfrågor och en slinga för att ladda ner 4000 databasposter från 4000 webbsidor - Excel-tips

Innehållsförteckning

En dag fick jag ett e-postmeddelande från Jan vid PMA. Hon passerade en bra idé från Gary Gagliardi från Clearbridge Publishing. Gary nämnde att vissa sökmotorer tilldelar en sidrankning till en sida baserat på hur många andra webbplatser som länkar till sidan. Han föreslog att om alla 4000 medlemmar i PMA skulle länka till alla 4000 andra medlemmar i PMA, skulle det öka alla våra rankningar. Jan tyckte att det här var en bra idé och sa att alla webbadresser för PMA-medlemmar listas på den aktuella PMA-webbplatsen i medlemsområdet.

Personligen tycker jag att "antal länkar" -teorin är lite av en myt, men jag var villig att prova för att hjälpa till.

Så jag besökte PMA Members-området, där jag snabbt fick reda på att det inte fanns en enda medlemslista, utan faktiskt 27 medlemslistor.

Jag besökte området PMA Members.

När jag klickade igenom "A" -sidan såg jag att det var ännu värre. Varje länk på den här sidan ledde inte till medlemmens webbplats. Varje länk här leder till en enskild sida på PMA-online med medlemmens webbplats.

Länkar på webbsidan.

Detta skulle innebära att jag måste besöka tusentals webbsidor för att sammanställa medlemslistan. Detta skulle helt klart vara ett vansinnigt förslag.

Lyckligtvis är jag medförfattare till VBA och makron för Microsoft Excel. Jag undrade om jag kunde anpassa koden från boken för att lösa problemet med att extrahera medlems-URL: er från tusentals länkade sidor.

Kapitel 14 i boken handlar om att använda Excel för att läsa från och skriva till webben. På sidan 335 hittade jag kod som kunde skapa en webbfråga direkt.

Det första steget var att se om jag kunde anpassa koden i boken för att kunna producera 27 webbfrågor - en för var och en av bokstäverna i alfabetet och siffran 1. Detta skulle ge mig flera listor över alla länkar på 26 alfabetiska sidlistor.

Varje sida har en URL som liknar http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Jag tog koden från sidan 335 och anpassade den lite för att göra 27 webbfrågor.

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 fanns fyra artiklar som anpassades i ovanstående kod.

  • Först var jag tvungen att bygga rätt URL. Detta uppnåddes genom att lägga till rätt bokstav i slutet av URL-strängen.
  • För det andra ändrade jag koden för att köra varje fråga på ett nytt kalkylblad i arbetsboken.
  • För det tredje tog koden i boken den 20: e tabellen från webbsidan. Genom att spela in ett makro som drar in tabellen från PMA lärde jag mig att jag behövde den sjunde tabellen på webbsidan.
  • För det fjärde, efter att ha kört makrot, blev jag besviken över att se att jag fick namnen på utgivarna, men inte hyperlänkarna. Koden i den angivna boken .WebFormatting: = xlFormattingNone. Med hjälp av VBA-hjälp tänkte jag att om jag ändrade till .WebFormatting: = xlFormattingAll skulle jag få de faktiska hyperlänkarna.

Efter att ha kört detta första makro hade jag 27 kalkylblad, var och en med en serie hyperlänkar som såg ut så här:

Extraherade länkar med hyperlänkar i Excel.

Nästa steg var att extrahera den hyperlänkade adressen från varje hyperlänk på de 27 kalkylbladen. Det finns inte i boken, men det finns ett hyperlänkobjekt i Excel. Objektet har en .Address-egenskap som returnerar webbsidan inom PMA-Online med URL för den utgivaren.

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 att ha kört detta makro fick jag äntligen veta att det fanns 4119 enskilda webbsidor på PMA-webbplatsen. Jag är glad att jag inte försökte besöka varje enskild webbplats en i taget!

Mitt nästa mål var att bygga en webbfråga för att besöka var och en av de 4119 enskilda webbsidorna. Jag spelade in ett makro som returnerade en av de enskilda förläggarsidorna för att lära mig att jag ville ha tabell 5 från varje sida. Jag kunde se att utgivarens namn returnerades som den femte raden i tabellen. I de flesta fall returnerades webbplatsen som den 13: e raden. Men jag lärde mig att i vissa fall, om gatuadressen var 3 rader istället för 2, var webbadressen faktiskt på rad 14. Om de hade 3 telefoner istället för 2, sköts webbplatsen ner en annan rad. Makronet måste vara tillräckligt flexibelt för att kunna söka från rad 13 till 18 för att hitta cellen som startade WWW :.

Det fanns ett annat dilemma. Koden i boken gör att webbfrågan kan uppdateras i bakgrunden. I de flesta fall skulle jag faktiskt titta på frågan avslutad efter att makrot var klart. Min första tanke var att tillåta 40 rader för varje utgivare och att bygga alla 4100 frågor på varje sida. Detta skulle ha krävt 80 000 rader kalkylark och mycket minne. I Excel 2002 experimenterade jag med att ändra BackgroundRefresh till False. VBA gjorde ett bra jobb med att hämta informationen i kalkylbladet innan makrot fortsatte. Detta kan vara att bygga frågan, uppdatera frågan, spara värdena i en databas och sedan ta bort frågan. Med den här metoden fanns det aldrig mer än en fråga i taget på kalkylbladet.

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

Den här frågan tog mer än en timme att köra. När allt kommer omkring gjorde det arbetet med att besöka över 4000 webbsidor. Det kördes utan problem och kraschade inte datorn eller Excel.

Sedan hade jag en trevlig databas i Excel med utgivarnamn i kolumn A och webbplatsen i kolumn B. Efter att ha sorterat efter webbplats i kolumn B fann jag att över 1000 utgivare inte listade en webbplats. Deras post i kolumn B var en tom URL. Jag sorterade och raderade dessa rader.

De webbplatser som anges i kolumn B hade också "WWW:" före varje URL. Jag använde en Redigera> Ersätt för att ändra varje förekomst av WWW: (med ett mellanslag efter det) till ingenting. Jag hade en trevlig lista över 2339 utgivare i ett kalkylark.

Förlagslista i kalkylbladet.

Det sista steget var att skriva ut en textfil som kunde kopieras och klistras in på medlemmarnas webbplats. Följande makro (anpassad från koden på sidan 345) hanterade den här uppgiften snyggt.

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 textfil med namn och URL på 2000+ utgivare.

All ovanstående kod anpassades från boken. När jag började gjorde jag bara ett engångsprogram som jag inte föreställde mig att jag skulle köra regelbundet. Men jag kan nu avbilda att gå tillbaka till PMA-webbplatsen varje månad eller så för att få de uppdaterade listorna med URL: er.

Det skulle vara möjligt att placera alla ovanstående steg i ett enda 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 och VBA gav ett snabbt alternativ till att besöka tusentals webbsidor individuellt. I teorin borde PMA ha kunnat fråga sin databas och tillhandahålla denna information mycket snabbare än att använda den här metoden. Ibland har du dock att göra med någon som inte är samarbetsvillig eller kanske inte vet hur man får ut data från en databas som någon annan skrev för dem. I det här fallet löste lite VBA-makrokod vårt problem.

Intressanta artiklar...