Egy nap kaptam egy sugárzott e-mailt Jan-tól a PMA-nál. Gary Gagliardi, a Clearbridge Publishing nagyszerű ötletét adta át. Gary megemlítette, hogy egyes keresőmotorok egy oldalhoz rangsorolást adnak annak alapján, hogy hány más webhely hivatkozik az oldalra. Azt javasolta, hogy ha a PMA mind a 4000 tagja összekapcsolódna a PMA mind a 4000 tagjával, az az összes ranglistánkat javítaná. Jan szerint ez remek ötlet volt, és azt mondta, hogy az összes PMA tag webcím fel van tüntetve a tagok jelenlegi PMA webhelyén.
Személy szerint azt gondolom, hogy a "linkek száma" elmélet kissé mítosz, de hajlandó voltam kipróbálni a segítség érdekében.
Tehát meglátogattam a PMA Tagok területét, ahol gyorsan megtudtam, hogy nem egyetlen, hanem 27 taglista létezik.
Amikor átkattantam az "A" oldalra, láttam, hogy ez még rosszabb. Ezen az oldalon minden link nem a tag weboldalára vezetett. Minden itt található link a PMA-online egy egyedi oldalára vezet a tag weboldalával.
Ez azt jelentené, hogy több ezer weboldalt kellene meglátogatnom a tagok listájának összeállításához. Ez egyértelműen őrült javaslat lenne.
Szerencsére a VBA és makrók társszerzője vagyok a Microsoft Excel számára. Kíváncsi voltam, testreszabhatom-e a könyv kódját, hogy megoldjam a tag URL-ek kibontásának problémáját több ezer összekapcsolt oldalról.
A könyv 14. fejezete arról szól, hogy az Excel hogyan használható az internetről történő olvasáshoz és az internetes íráshoz. A 335. oldalon találtam egy kódot, amely menet közben webkérdést hozhat létre.
Az első lépés annak megvizsgálása volt, hogy testreszabhatom-e a könyv kódját, hogy 27 webes lekérdezést tudjak készíteni - egyet az ábécé minden betűjéhez és az 1. számot. Ez több listát ad nekem a 26 betűrendes oldaljegyzék.
Minden oldal URL-je hasonló a http://www.pma-online.org/scripts/showmemlist.cfm?letter=A címhez. Kódot vettem a 335. oldalról, és kicsit testreszabtam 27 webes lekérdezés elvégzéséhez.
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 SubNégy elem volt testreszabva a fenti kódban.
- Először a helyes URL-t kellett elkészítenem. Ezt úgy értük el, hogy a megfelelő betűt hozzáfűztük az URL karakterlánc végéhez.
- Másodszor módosítottam a kódot, hogy minden lekérdezést egy új munkalapon futtassak a munkafüzetben.
- Harmadszor, a könyv kódja megragadta a 20. táblázatot a weboldalról. A PMA-ból a táblázatba behúzott makró rögzítésével megtudtam, hogy szükségem van a weboldal 7. táblájára.
- Negyedszer, a makró futtatása után csalódottan tapasztaltam, hogy a kiadók nevét kaptam, a hiperhivatkozásokat viszont nem. A könyv kódja megadta .WebFormatting: = xlFormattingNone. A VBA segítség segítségével arra gondoltam, hogy ha .WebFormatting: = xlFormattingAll-ra váltok, akkor megkapom a tényleges hiperhivatkozásokat.
Az első makró futtatása után 27 munkalapom volt, mindegyiken egy sor hiperhivatkozás volt, amely így nézett ki:
A következő lépés a hiperhivatkozott cím kibontása volt a 27 munkalap minden hiperhivatkozásából. Ez nem szerepel a könyvben, de van egy hiperlink objektum az Excelben. Az objektumnak van egy .Address tulajdonsága, amely visszaadja a PMA-Online weboldalát az adott kiadó URL-jével.
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 SubA makró futtatása után végül megtudtam, hogy 4119 egyedi weboldal található a PMA webhelyén. Örülök, hogy nem próbáltam meglátogatni az egyes oldalakat egyenként!
A következő célom az volt, hogy web-lekérdezést készítsek a 4119 egyedi weboldal meglátogatására. Felvettem egy makrót, amely visszaküldte az egyes megjelenítői oldalakat, és megtudta, hogy az 5. táblázatot szeretném minden oldalról. Láttam, hogy a kiadó nevét a táblázat ötödik soraként adtuk vissza. A legtöbb esetben a webhelyet 13. sorként adták vissza. Megtanultam azonban, hogy bizonyos esetekben, ha az utca címe 2 helyett 3 vonal volt, akkor a webhely URL-je valójában a 14. sorban volt. Ha 2 telefon helyett 3 telefonjuk van, akkor a webhelyet egy újabb sorral lenyomják. A makrónak elég rugalmasnak kell lennie ahhoz, hogy a 13–18. Sorok között keresgélhessen, hogy megtalálja azt a cellát, amely elindította a WWW :.
Volt egy másik dilemma. A könyvben található kód lehetővé teszi az internetes lekérdezés frissítését a háttérben. A legtöbb esetben valóban a makró befejezése után végignézném a lekérdezés befejezését. A kezdeti gondolatom az volt, hogy engedélyezzek 40 sort minden kiadó számára, és minden oldalra felépítsem mind a 4100 kérdést. Ehhez 80 000 sor táblára és sok memóriára lett volna szükség. Az Excel 2002-ben kísérleteztem a BackgroundRefresh hamisra változtatásával. A VBA jól elvégezte az információ behúzását a munkalapba, mielőtt a makró folytatódott volna. Ez lehetővé teszi a lekérdezés felépítését, a lekérdezés frissítését, az értékek mentését egy adatbázisba, majd a lekérdezés törlését. Ezzel a módszerrel soha nem volt több, mint egy lekérdezés egyszerre a munkalapon.
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 SubEz a lekérdezés több mint egy órát vett igénybe. Végül is több mint 4000 weboldal meglátogatását végezte. Gond nélkül futott, és nem ütközött össze a számítógép vagy az Excel.
Ezután volt egy szép adatbázisom az Excel-ben, a Publisher névvel az A oszlopban, a webhely pedig a B oszlopban. Miután a B oszlopban rendeztem a webhelyeket, azt tapasztaltam, hogy több mint 1000 kiadó nem sorolt fel webhelyet. A B. oszlopba való bejegyzésük üres URL volt. Rendeztem és töröltem ezeket a sorokat.
Ezenkívül a B. oszlopban felsorolt webhelyeken minden URL előtt volt „WWW:”. A Szerkesztés> Csere elemet használtam, hogy a WWW minden előfordulását: (szóközzel utána) semmivé változtassam. Volt egy szép listám 2339 kiadóról egy táblázatban.
Az utolsó lépés egy olyan szöveges fájl kiírása volt, amely másolható és beilleszthető bármely tag weboldalára. A következő makró (a 345. oldalon található kódból adaptálva) szépen kezelte ezt a feladatot.
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 SubAz eredmény egy szöveges fájl volt, amely legalább 2000 kiadó nevét és URL-jét tartalmazta.
Az összes fenti kódot adaptálták a könyvből. Amikor elindultam, csak egyszeri programot csináltam, amelyet nem gondoltam rendszeresen. Most azonban képes vagyok havonta visszamenni a PMA webhelyére, hogy megkaphassam az URL-ek frissített listáit.
Lehetséges lenne a fenti lépések összesítését egyetlen makróba tenni.
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 SubAz Excel és a VBA gyors alternatívát nyújtott a több ezer weboldal egyedi meglátogatásához. Elméletileg a PMA-nak képesnek kellett lennie arra, hogy lekérdezze az adatbázisukat, és ezeket az információkat sokkal gyorsabban megadja, mint ezzel a módszerrel. Néha azonban olyan valakivel van dolga, aki nem együttműködik, vagy esetleg nem tudja, hogyan hozza ki az adatokat egy adatbázisból, amelyet valaki más írt neki. Ebben az esetben egy kis VBA makrokód megoldotta a problémánkat.
