Korištenje web upita i petlje za preuzimanje 4000 unosa u bazu podataka s 4000 web stranica - Excel savjeti

Sadržaj

Jednog dana primio sam e-mail od Jana na PMA. Prenosila je sjajnu ideju Garyja Gagliardija iz Clearbridge Publishinga. Gary je spomenuo da neke tražilice stranici dodjeljuju rang stranice na temelju broja drugih web stranica koje vode do stranice. Sugerirao je da bi, ako bi se svih 4000 članova PMA povezalo sa svih 4000 ostalih članova PMA-a, to potaknulo sve naše ljestvice. Jan je smatrao da je ovo dobra ideja i rekao je da su sve web adrese članova PMA navedene na trenutnoj web stranici PMA u području članova.

Osobno mislim da je teorija "broja poveznica" pomalo mit, ali bio sam spreman pokušati kako bih pomogao.

Tako sam posjetio područje članova PMA-a, gdje sam brzo saznao da ne postoji niti jedan popis članova, već zapravo 27 popisa članova.

Posjetio sam područje članova PMA.

Kad sam kliknuo na stranicu "A", vidio sam da je to još gore. Svaka poveznica na ovoj stranici nije vodila do web mjesta člana. Svaka ovdje poveznica vodi do pojedinačne stranice na PMA-online s web stranicom člana.

Veze na web stranici.

To bi značilo da bih morao posjetiti tisuće web stranica kako bih sastavio popis članova. To bi očito bio sulud prijedlog.

Srećom, koautor sam VBA i makronaredbi za Microsoft Excel. Pitao sam se mogu li prilagoditi kod iz knjige kako bih riješio problem izdvajanja URL-ova članova s ​​tisuća povezanih stranica.

14. poglavlje knjige govori o korištenju programa Excel za čitanje i pisanje na mrežu. Na stranici 335 pronašao sam kôd koji bi mogao stvoriti web upit u letu.

Prvi korak bio je vidjeti mogu li prilagoditi kod iz knjige kako bih mogao proizvesti 27 web upita - po jedan za svako slovo abecede i broj 1. To bi mi dalo nekoliko popisa svih poveznica na 26 abecednih popisa stranica.

Svaka stranica ima URL sličan http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Uzeo sam kod sa stranice 335 i malo ga prilagodio za 27 web upita.

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

U gornjem kodu bile su prilagođene četiri stavke.

  • Prvo sam morao stvoriti točan URL. To je postignuto dodavanjem odgovarajućeg slova na kraj URL-a.
  • Drugo, izmijenio sam kôd kako bih pokrenuo svaki upit na novom radnom listu u radnoj knjizi.
  • Treće, kod u knjizi grabio je 20. tablicu s web stranice. Snimanjem makronavlačenja u tablicu s PMA-a saznao sam da mi treba 7. tablica na web stranici.
  • Četvrto, nakon pokretanja makronaredbe bio sam razočaran kad sam vidio da dobivam imena izdavača, ali ne i hiperveze. Kod u knjizi je naveden .WebFormatting: = xlFormattingNone. Koristeći pomoć VBA, zaključio sam da ću, ako se promijenim u .WebFormatting: = xlFormattingAll, dobiti stvarne hiperveze.

Nakon pokretanja ove prve makronaredbe, imao sam 27 radnih listova, svaki sa nizom hiperveza koje su izgledale ovako:

Izdvojene veze s hipervezama u Excelu.

Sljedeći je korak bio izdvajanje adrese hiperveze iz svake hiperveze na 27 radnih listova. Nema je u knjizi, ali u Excelu postoji objekt hiperveze. Objekt ima svojstvo .Address koje bi vratilo web stranicu unutar PMA-Online s URL-om tog izdavača.

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

Nakon pokretanja ove makronaredbe napokon sam saznao da na web mjestu PMA postoji 4119 pojedinačnih web stranica. Drago mi je što nisam pokušao posjetiti svaku pojedinu stranicu jednu po jednu!

Moj sljedeći cilj bio je napraviti web-upit za posjećivanje svake od 4119 pojedinačnih web-stranica. Snimio sam makronaredbu koja vraća jednu od pojedinačnih stranica izdavača kako bih saznao da želim tablicu br. 5 sa svake stranice. Vidio sam da je ime izdavača vraćeno kao peti red tablice. U većini slučajeva web mjesto je vraćeno kao 13. red. Međutim, saznao sam da je u nekim slučajevima, ako je adresa ulice bila 3 retka umjesto 2, URL web mjesta zapravo bio u retku 14. Ako su imali 3 telefona umjesto 2, web mjesto je gurnuto za drugi red. Makronaredba bi trebala biti dovoljno fleksibilna za pretragu od možda redaka 13 do 18 kako bi se pronašla ćelija koja je pokrenula WWW :.

Postojala je još jedna dilema. Kôd u knjizi omogućuje osvježavanje web upita u pozadini. U većini bih slučajeva zapravo gledao završetak upita nakon završetka makronaredbe. Moja početna misao bila je dopustiti 40 redaka za svakog izdavača i izgraditi svih 4100 upita na svakoj stranici. To bi zahtijevalo 80 000 redaka proračunske tablice i puno memorije. U programu Excel 2002 eksperimentirao sam s promjenom BackgroundRefresh u False. VBA je dobro uspio uvući podatke u radni list prije nego što se makronaredba nastavi. To bi moglo biti izrada upita, osvježavanje upita, spremanje vrijednosti u bazu podataka, a zatim brisanje upita. Korištenjem ove metode na radnom listu nikad nije bilo više odjednom upita.

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

Pokretanju ovog upita trebalo je više od sat vremena. Napokon, obavljao je posao na posjetu preko 4000 web stranica. Pokrenuo se bez problema i nije srušio računalo ili Excel.

Tada sam imao lijepu bazu podataka u Excelu s imenom izdavača u stupcu A i web mjestu u stupcu B. Nakon sortiranja po web mjestu u stupcu B, otkrio sam da preko 1000 izdavača nije navelo web mjesto. Njihov unos u stupac B bio je prazan URL. Razvrstao sam i izbrisao ove retke.

Također, web mjesta navedena u stupcu B imala su "WWW:" prije svakog URL-a. Koristio sam Uredi> Zamijeni da bih promijenio svaku pojavu WWW: (s razmakom nakon nje) u ništa. Imao sam lijep popis od 2339 izdavača u proračunskoj tablici.

Popis izdavača u proračunskoj tablici.

The last step was to write out a text file that could be copied and pasted into any members' website. The following macro (adapted from the code on page 345) handled this task nicely.

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

The result was a text file with the name and URL of 2000+ publishers.

All of the above code was adapted from the book. When I started, I was sort of just doing a one-off program that I didn't envision running regularly. However, I can now imaging going back to the PMA website every month or so to get the updated lists of URL's.

It would be possible to put all of the above steps into a single macro.

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 and VBA provided a quick alternative to individually visiting thousands of web pages. In theory, the PMA should have been able to query their database and provide this information far more quickly than using this method. However, sometimes you are dealing with someone who is uncooperative or possibly doesn't know how to get data out of a database that someone else wrote for them. In this case, a bit of VBA macro code solved our problem.

Zanimljivi članci...