Pewnego dnia otrzymałem e-mail transmisyjny od Jana z PMA. Przekazała świetny pomysł Gary'ego Gagliardiego z Clearbridge Publishing. Gary wspomniał, że niektóre wyszukiwarki przypisują rangę strony do strony na podstawie tego, ile innych witryn zawiera linki do tej strony. Sugerował, że gdyby wszyscy 4000 członków PMA połączyli się ze wszystkimi 4000 innymi członkami PMA, poprawiłoby to wszystkie nasze rankingi. Jan uznał, że to świetny pomysł i powiedział, że wszystkie adresy internetowe członków PMA są wymienione na aktualnej stronie internetowej PMA w obszarze członków.
Osobiście uważam, że teoria „liczby linków” to trochę mit, ale byłem skłonny spróbować, aby pomóc.
Odwiedziłem więc strefę członków PMA, gdzie szybko dowiedziałem się, że nie ma jednej listy członków, a w rzeczywistości 27 list członków.
Kiedy kliknąłem na stronę „A”, zobaczyłem, że było jeszcze gorzej. Każde łącze na tej stronie nie prowadziło do witryny internetowej członka. Każde łącze prowadzi do indywidualnej strony w PMA-online z witryną członka.
Oznaczałoby to, że musiałbym odwiedzić tysiące stron internetowych, aby sporządzić listę członków. To byłaby oczywiście szalona propozycja.
Na szczęście jestem współautorem VBA i makr dla Microsoft Excel. Zastanawiałem się, czy mógłbym dostosować kod z książki, aby rozwiązać problem wyodrębniania adresów URL członków z tysięcy powiązanych stron.
Rozdział 14 książki dotyczy używania programu Excel do czytania i pisania w Internecie. Na stronie 335 znalazłem kod, który mógłby w locie utworzyć kwerendę sieciową.
Pierwszym krokiem było sprawdzenie, czy uda mi się dostosować kod w książce, aby móc wygenerować 27 zapytań internetowych - po jednym dla każdej litery alfabetu i cyfry 1. To dałoby mi kilka list wszystkich linków w 26 alfabetycznych spisów stron.
Każda strona ma adres URL podobny do http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Wziąłem kod ze strony 335 i dostosowałem go trochę, aby wykonać 27 zapytań internetowych.
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 SubW powyższym kodzie były cztery elementy, które zostały dostosowane.
- Najpierw musiałem zbudować poprawny adres URL. Osiągnięto to poprzez dołączenie odpowiedniej litery na końcu ciągu adresu URL.
- Po drugie, zmodyfikowałem kod, aby uruchamiać każde zapytanie w nowym arkuszu w skoroszycie.
- Po trzecie, kod w książce przechwytywał dwudziestą tabelę ze strony internetowej. Nagrywając makra w tabeli z PMA, dowiedziałem się, że potrzebuję siódmej tabeli na stronie internetowej.
- Po czwarte, po uruchomieniu makra byłem rozczarowany, widząc, że otrzymuję nazwy wydawców, ale nie hiperłącza. Kod w książce określony .WebFormatting: = xlFormattingNone. Korzystając z pomocy VBA, doszedłem do wniosku, że jeśli zmienię na .WebFormatting: = xlFormattingAll, otrzymam rzeczywiste hiperłącza.
Po uruchomieniu tego pierwszego makra miałem 27 arkuszy roboczych, z których każdy zawierał serię hiperłączy, które wyglądały następująco:
Następnym krokiem było wyodrębnienie adresu hiperłącza z każdego hiperłącza w 27 arkuszach. Nie ma tego w książce, ale w programie Excel znajduje się obiekt hiperłącza. Obiekt ma właściwość .Address, która zwróci stronę internetową w ramach usługi PMA-Online z adresem URL tego wydawcy.
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 uruchomieniu tego makra w końcu dowiedziałem się, że w witrynie PMA jest 4119 pojedynczych stron internetowych. Cieszę się, że nie próbowałem odwiedzać każdej strony pojedynczo!
Moim następnym celem było zbudowanie zapytania internetowego w celu odwiedzenia każdej z 4119 indywidualnych stron internetowych. Zarejestrowałem makro zwracające jedną ze stron poszczególnych wydawców, aby dowiedzieć się, że chcę mieć tabelę nr 5 z każdej strony. Widziałem, że nazwa wydawcy została zwrócona jako piąty wiersz tabeli. W większości przypadków witryna była zwracana jako 13. wiersz. Jednak dowiedziałem się, że w niektórych przypadkach, jeśli adres pocztowy zawierał 3 wiersze zamiast 2, adres URL witryny znajdował się w wierszu 14. Jeśli mieli 3 telefony zamiast 2, witryna została przesunięta w dół o kolejny wiersz. Makro musiałoby być wystarczająco elastyczne, aby wyszukiwać w wierszach od 13 do 18 w celu znalezienia komórki, która uruchomiła WWW :.
Był jeszcze jeden dylemat. Kod w książce umożliwia odświeżanie zapytania internetowego w tle. W większości przypadków obserwowałbym zakończenie zapytania po zakończeniu działania makra. Moją początkową myślą było zezwolenie na 40 wierszy dla każdego wydawcy i zbudowanie wszystkich 4100 zapytań na każdej stronie. Wymagałoby to 80 000 wierszy arkusza kalkulacyjnego i dużo pamięci. W programie Excel 2002 eksperymentowałem ze zmianą BackgroundRefresh na False. VBA wykonał dobrą robotę, wciągając informacje do arkusza roboczego przed uruchomieniem makra. Pozwoliło to na zbudowanie zapytania, odświeżenie zapytania, zapisanie wartości w bazie danych, a następnie usunięcie zapytania. Korzystając z tej metody, w arkuszu nigdy nie było więcej niż jedno zapytanie naraz.
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 SubWykonanie tego zapytania zajęło ponad godzinę. Przecież wykonywał pracę polegającą na odwiedzaniu ponad 4000 stron internetowych. Działał bez problemów i nie powodował awarii komputera ani programu Excel.
Miałem wtedy ładną bazę danych w Excelu z nazwą wydawcy w kolumnie A i stroną internetową w kolumnie B. Po posortowaniu stron internetowych w kolumnie B stwierdziłem, że ponad 1000 wydawców nie umieściło na liście witryn internetowych. Ich wpis w kolumnie B był pustym adresem URL. Posortowałem i usunąłem te wiersze.
Ponadto strony internetowe wymienione w kolumnie B miały przed każdym adresem URL „WWW:”. Użyłem Edytuj> Zastąp, aby zmienić każde wystąpienie WWW: (ze spacją po nim) na nic. Miałem ładną listę 2339 wydawców w arkuszu kalkulacyjnym.
Ostatnim krokiem było napisanie pliku tekstowego, który można skopiować i wkleić na stronie internetowej dowolnego członka. Następujące makro (zaadaptowane z kodu na stronie 345) dobrze sobie z tym poradziło.
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 SubW rezultacie powstał plik tekstowy z nazwą i adresem URL ponad 2000 wydawców.
Cały powyższy kod został zaadaptowany z książki. Kiedy zaczynałem, robiłem taki jednorazowy program, którego nie wyobrażałem sobie regularnie. Mogę jednak teraz tworzyć obrazy, wracając co miesiąc do witryny PMA, aby uzyskać zaktualizowane listy adresów URL.
Byłoby możliwe umieszczenie wszystkich powyższych kroków w jednym makrze.
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 i VBA stanowiły szybką alternatywę dla indywidualnego odwiedzania tysięcy stron internetowych. Teoretycznie PMA powinien był w stanie przeszukać swoją bazę danych i dostarczyć te informacje znacznie szybciej niż przy użyciu tej metody. Czasami jednak masz do czynienia z kimś, kto nie chce współpracować lub prawdopodobnie nie wie, jak wydobyć dane z bazy danych, którą napisał dla niej ktoś inny. W tym przypadku fragment kodu makr VBA rozwiązał nasz problem.
