Tīmekļa vaicājumu un cikla izmantošana, lai lejupielādētu 4000 datu bāzes ierakstus no 4000 vietnēm - Excel padomi

Satura rādītājs

Kādu dienu es saņēmu apraides e-pastu no Jana PMA. Viņa nodeva lielisku ideju no Gerija Gagliardi no Clearbridge Publishing. Gerijs minēja, ka dažas meklētājprogrammas piešķir lapai lapas rangu, pamatojoties uz to, cik citas vietnes novirza uz lapu. Viņš ieteica, ka, ja visi 4000 PMA locekļi būtu saistīti ar visiem 4000 citiem PMA locekļiem, tas veicinātu visu mūsu rangu. Jans domāja, ka tā ir lieliska ideja, un teica, ka visas PMA dalībnieku tīmekļa adreses ir norādītas pašreizējā PMA vietnē dalībnieku apgabalā.

Personīgi es domāju, ka "saišu skaita" teorija ir mazliet mīts, taču es biju gatavs to izmēģināt, lai palīdzētu.

Tātad, es apmeklēju PMA biedru zonu, kur ātri uzzināju, ka nav viens dalībnieku saraksts, bet faktiski 27 biedru saraksti.

Es apmeklēju PMA biedru zonu.

Noklikšķinot uz A lapas, es redzēju, ka tā ir vēl sliktāka. Katra saite šajā lapā nenonāca uz dalībnieka vietni. Katra saite ved uz atsevišķu lapu PMA-online ar dalībnieka vietni.

Saites tīmekļa lapā.

Tas nozīmētu, ka man būtu jāapmeklē tūkstošiem tīmekļa lapu, lai sastādītu dalībnieku sarakstu. Tas viennozīmīgi būtu nenormāls piedāvājums.

Par laimi esmu Microsoft VBA un makro līdzautors. Es prātoju, vai es varētu pielāgot grāmatas kodu, lai atrisinātu problēmu, kā dalībnieku URL iegūt no tūkstošiem saistītu lapu.

Grāmatas 14. nodaļa ir par programmas Excel izmantošanu lasīšanai un rakstīšanai tīmeklī. 335. lappusē es atradu kodu, kas varētu izveidot tīmekļa vaicājumu lidojuma laikā.

Pirmais solis bija noskaidrot, vai es varu pielāgot grāmatas kodu, lai varētu sastādīt 27 tīmekļa vaicājumus - pa vienam katram alfabēta burtam un skaitlim 1. Tas man dotu vairākus visu saišu sarakstus. 26 alfabētiski lapu saraksti.

Katras lapas URL ir līdzīgs vietnei http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Es paņēmu kodu no 335. lapas un mazliet pielāgoju to, lai veiktu 27 tīmekļa vaicājumus.

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

Iepriekš minētajā kodā tika pielāgoti četri vienumi.

  • Pirmkārt, man bija jāizveido pareizs URL. Tas tika panākts, pievienojot pareizo burtu URL virknes beigās.
  • Otrkārt, es pārveidoju kodu, lai katru vaicājumu palaistu jaunā darbgrāmatas darblapā.
  • Treškārt, grāmatas kods satvēra 20. tabulu no tīmekļa lapas. Ierakstot makro, kas no PMA ievelk tabulu, es uzzināju, ka man ir nepieciešama tīmekļa tabulas 7. tabula.
  • Ceturtkārt, pēc makro palaišanas es biju vīlies, redzot, ka es saņēmu izdevēju vārdus, bet ne hipersaites. Norādītais kods grāmatā .WebFormatting: = xlFormattingNone. Izmantojot VBA palīdzību, es sapratu, ka, ja es mainītu uz .WebFormatting: = xlFormattingAll, es saņemtu faktiskās hipersaites.

Pēc šī pirmā makro palaišanas man bija 27 darblapas, katrā no tām bija virkne hipersaites, kas izskatījās šādi:

Izvilktas saites ar hipersaitēm programmā Excel.

Nākamais solis bija hipersaites adreses izvilkšana no katras hipersaites 27 darblapās. Tas nav grāmatā, bet programmā Excel ir hipersaites objekts. Objektam ir rekvizīts .Address, kas atgriezīs tīmekļa vietni PMA-Online ar šī izdevēja URL.

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ēc šī makro palaišanas es beidzot uzzināju, ka PMA vietnē ir 4119 atsevišķas tīmekļa lapas. Es priecājos, ka es nemēģināju apmeklēt katru vietni pa vienam!

Mans nākamais mērķis bija izveidot tīmekļa vaicājumu, lai apmeklētu katru no 4119 atsevišķajām tīmekļa lapām. Es ierakstīju makro, kas atgriež vienu no atsevišķām izdevēja lapām, lai uzzinātu, ka no katras lapas vēlos 5. tabulu. Varēju redzēt, ka izdevēja nosaukums tika atgriezts kā tabulas piektā rinda. Vairumā gadījumu vietne tika atgriezta kā 13. rinda. Tomēr es uzzināju, ka dažos gadījumos, ja ielas adrese bija 3 līnijas, nevis 2, vietnes URL faktiski atradās 14. rindā. Ja viņiem bija 3 tālruņi, nevis 2, vietne tika nobīdīta vēl vienā rindā. Makro būtu jābūt pietiekami elastīgam, lai meklētu, iespējams, no 13. līdz 18. rindai, lai atrastu šūnu, ar kuru sākta WWW :.

Bija vēl viena dilemma. Grāmatas kods ļauj tīmekļa vaicājumu atsvaidzināt fonā. Vairumā gadījumu es patiešām skatītos vaicājuma pabeigšanu pēc makro pabeigšanas. Mana sākotnējā doma bija atļaut katram izdevējam 40 rindas un katrā lapā izveidot visus 4100 vaicājumus. Tam būtu nepieciešamas 80 000 izklājlapu rindas un daudz atmiņas. Programmā Excel 2002 es eksperimentēju, mainot BackgroundRefresh uz False. VBA paveica labu darbu, ievilkot informāciju darblapā, pirms makro turpinās. Tas ļāva izveidot vaicājumu, atsvaidzināt vaicājumu, saglabāt vērtības datu bāzē un pēc tam izdzēst vaicājumu. Izmantojot šo metodi, darblapā nekad vienlaikus nebija vairāk par vienu vaicājumu.

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

Šī vaicājuma izpilde aizņēma vairāk nekā stundu. Galu galā tas veica darbu, apmeklējot vairāk nekā 4000 tīmekļa lapas. Tas tiešām darbojās bez aizķeršanās un nesabojāja datoru vai Excel.

Pēc tam man bija jauka datu bāze programmā Excel ar Publisher nosaukumu A slejā un vietni B slejā. Pēc šķirošanas pēc vietnes B slejā es atklāju, ka vairāk nekā 1000 izdevēju neuzskaitīja vietni. Viņu ieraksts B slejā bija tukšs URL. Es kārtoju un izdzēsu šīs rindas.

Turklāt B slejā uzskaitītajām vietnēm pirms katra URL bija “WWW:”. Es izmantoju Rediģēt> Aizstāt, lai katru WWW gadījumu (ar atstarpi aiz tā) mainītu uz neko. Man izklājlapā bija jauks saraksts ar 2339 izdevējiem.

Izdevēju saraksts izklājlapā.

Pēdējais solis bija teksta faila izrakstīšana, kuru varēja nokopēt un ielīmēt jebkura dalībnieka vietnē. Šis makro (pielāgots no koda 345. lpp.) Lieliski tika galā ar šo uzdevumu.

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

Rezultātā tika iegūts teksta fails ar vismaz 2000 izdevēju nosaukumu un URL.

Viss iepriekš minētais kods tika pielāgots no grāmatas. Kad es sāku, es kaut kā vienkārši veicu vienreizēju programmu, kuru es neparedzēju regulāri darboties. Tomēr tagad es varu katru mēnesi atgriezties PMA vietnē, lai iegūtu atjauninātus URL sarakstus.

Visas iepriekš minētās darbības būtu iespējams salikt vienā 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 un VBA nodrošināja ātru alternatīvu tūkstošiem tīmekļa lapu individuālai apmeklēšanai. Teorētiski PMA bija jāspēj veikt vaicājumu viņu datu bāzē un sniegt šo informāciju daudz ātrāk nekā izmantojot šo metodi. Tomēr dažreiz jums ir darīšana ar kādu, kurš nesadarbojas vai, iespējams, nezina, kā iegūt datus no datu bāzes, ko kāds cits viņiem ir uzrakstījis. Šajā gadījumā mazliet VBA makro koda atrisināja mūsu problēmu.

Interesanti raksti...