Jednoho dne jsem od Jana dostal vyslaný e-mail na PMA. Předávala skvělý nápad od Garyho Gagliardiho z Clearbridge Publishing. Gary zmínil, že některé vyhledávače přiřazují stránce hodnocení stránky podle toho, kolik dalších webů na stránku odkazuje. Navrhoval, že pokud by se všech 4000 členů PMA spojilo se všemi 4000 dalšími členy PMA, posílilo by to všechny naše žebříčky. Jan to považoval za skvělý nápad a řekl, že všechny webové adresy členů PMA jsou uvedeny na aktuálním webu PMA v oblasti členů.
Osobně si myslím, že teorie „počtu odkazů“ je trochu mýtus, ale byl jsem ochoten to zkusit, abych pomohl.
Navštívil jsem tedy oblast PMA Members, kde jsem se rychle dozvěděl, že neexistuje jediný seznam členů, ale ve skutečnosti 27 seznamů členů.
Když jsem se proklikal na stránku „A“, viděl jsem, že to bylo ještě horší. Každý odkaz na této stránce nevedl na web člena. Každý odkaz zde vede na samostatnou stránku na PMA-online s webem člena.
To by znamenalo, že bych musel navštívit tisíce webových stránek, abych mohl sestavit seznam členů. To by byl zjevně šílený návrh.
Naštěstí jsem spoluautorem VBA a maker pro Microsoft Excel. Napadlo mě, jestli mohu přizpůsobit kód z knihy tak, aby vyřešil problém s extrahováním členské adresy z tisíců propojených stránek.
Kapitola 14 knihy pojednává o používání aplikace Excel ke čtení a zápisu na web. Na stránce 335 jsem našel kód, který by mohl za běhu vytvořit webový dotaz.
Prvním krokem bylo zjistit, zda dokážu přizpůsobit kód v knize tak, aby byl schopen vytvořit 27 webových dotazů - jeden pro každé písmeno abecedy a číslo 1. To by mi dalo několik seznamů všech odkazů na 26 abecedních výpisů stránek.
Každá stránka má adresu URL podobnou adrese http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Vzal jsem kód ze stránky 335 a trochu jsem jej přizpůsobil, abych udělal 27 webových dotazů.
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 SubVe výše uvedeném kódu byly upraveny čtyři položky.
- Nejprve jsem musel vytvořit správnou adresu URL. Toho bylo dosaženo připojením správného písmene na konec řetězce URL.
- Zadruhé jsem upravil kód tak, aby spouštěl každý dotaz na novém listu v sešitu.
- Za třetí, kód v knize popadl 20. tabulku z webové stránky. Nahráním makra tahajícího tabulku z PMA jsem se dozvěděl, že potřebuji 7. tabulku na webové stránce.
- Za čtvrté, po spuštění makra jsem byl zklamaný, když jsem viděl, že dostávám jména vydavatelů, ale ne hypertextové odkazy. Kód v knize specifikoval. WebFormatting: = xlFormattingNone. Pomocí nápovědy VBA jsem přišel na to, že když jsem změnil na .WebFormatting: = xlFormattingAll, dostal bych skutečné hypertextové odkazy.
Po spuštění tohoto prvního makra jsem měl 27 pracovních listů, každý s řadou hypertextových odkazů, které vypadaly takto:
Dalším krokem byla extrakce adresy s hypertextovým odkazem z každého hypertextového odkazu na 27 pracovních listech. Není v knize, ale v aplikaci Excel je objekt hypertextového odkazu. Objekt má vlastnost .Address, která by vrátila webovou stránku v PMA-Online s adresou URL pro daného vydavatele.
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 SubPo spuštění tohoto makra jsem se konečně dozvěděl, že na webu PMA bylo 4119 jednotlivých webových stránek. Jsem rád, že jsem se nepokusil navštívit každý jednotlivý web po jednom!
Mým dalším cílem bylo vytvořit webový dotaz pro návštěvu každé z 4119 jednotlivých webových stránek. Zaznamenal jsem makro vracející jednu z jednotlivých stránek vydavatele, abych se dozvěděl, že chci tabulku č. 5 z každé stránky. Viděl jsem, že jméno vydavatele bylo vráceno jako pátý řádek tabulky. Ve většině případů byl web vrácen jako 13. řádek. Dozvěděl jsem se však, že v některých případech, pokud byla adresa ulice 3 řádky místo 2, byla adresa URL webových stránek ve skutečnosti na řádku 14. Pokud měli 3 telefony místo 2, byl web posunut o další řádek dolů. Makro by muselo být dostatečně flexibilní, aby mohlo vyhledávat snad od řádku 13 do 18, aby našlo buňku, která spustila WWW :.
Nastalo další dilema. Kód v knize umožňuje, aby se webový dotaz obnovil na pozadí. Ve většině případů bych vlastně sledoval dokončení dotazu po dokončení makra. Moje první myšlenka byla umožnit 40 řádků pro každého vydavatele a vytvořit všech 4100 dotazů na každé stránce. To by vyžadovalo 80 000 řádků tabulky a spoustu paměti. V aplikaci Excel 2002 jsem experimentoval se změnou BackgroundRefresh na False. VBA odvedl dobrou práci s tím, že vytáhl informace do listu, než bude makro pokračovat. To umožnilo vytvořit dotaz, aktualizovat dotaz, uložit hodnoty do databáze a poté dotaz odstranit. Při použití této metody na listu nikdy nebyl více než jeden dotaz najednou.
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 SubTento dotaz trval více než hodinu. Nakonec to byla práce na návštěvě více než 4 000 webových stránek. Fungovalo to bez problémů a nezničilo počítač ani Excel.
Poté jsem měl v Excelu pěknou databázi s názvem Publisher ve sloupci A a webem ve sloupci B. Po seřazení podle webu ve sloupci B jsem zjistil, že více než 1000 vydavatelů neuvádí seznam webových stránek. Jejich položka ve sloupci B byla prázdná URL. Řadil jsem a odstranil tyto řádky.
Weby uvedené ve sloupci B měly před každou adresou URL také „WWW:“. Použil jsem Upravit> Nahradit, abych změnil každý výskyt WWW: (s mezerou za ním) na nic. V tabulce jsem měl pěkný seznam 2339 vydavatelů.
Posledním krokem bylo napsání textového souboru, který lze zkopírovat a vložit na web libovolného člena. Následující makro (upravené z kódu na straně 345) zvládlo tento úkol pěkně.
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 SubVýsledkem byl textový soubor s názvem a adresou URL více než 2000 vydavatelů.
Veškerý výše uvedený kód byl převzat z knihy. Když jsem začínal, tak nějak jsem jen dělal jednorázový program, který jsem si nepředstavoval běžet pravidelně. Nyní však mohu zobrazování vracet každý měsíc zpět na web PMA, abych získal aktualizované seznamy adres URL.
Bylo by možné dát všechny výše uvedené kroky do jednoho makra.
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 SubExcel a VBA poskytly rychlou alternativu k individuální návštěvě tisíců webových stránek. Teoreticky by PMA měla být schopna vyhledávat v jejich databázi a poskytovat tyto informace mnohem rychleji než při použití této metody. Někdy však jednáte s někým, kdo nespolupracuje nebo možná neví, jak dostat data z databáze, kterou pro ně napsal někdo jiný. V tomto případě náš problém vyřešil trochu kódu makra VBA.
