Един ден получих излъчено имейл от Ян в PMA. Тя предаваше страхотна идея от Гари Галиарди от Clearbridge Publishing. Гари спомена, че някои търсачки присвояват ранг на страница на базата на това колко други сайтове водят към страницата. Той предполагаше, че ако всички 4000 членове на PMA се свържат с всички 4000 други членове на PMA, това ще увеличи всичките ни класации. Ян сметна, че това е чудесна идея и каза, че всички уеб адреси на членове на PMA са изброени на текущия уебсайт на PMA в областта за членове.
Лично аз мисля, че теорията за „броя на връзките“ е малко мит, но бях готов да опитам, за да помогна.
И така, посетих района на членовете на PMA, където бързо разбрах, че няма нито един списък с членове, а всъщност 27 списъка с членове.
Докато щракнах към страницата „А“, видях, че е още по-лошо. Всяка връзка на тази страница не води до уебсайта на члена. Всяка връзка тук води до отделна страница в PMA-online с уебсайта на члена.
Това би означавало, че ще трябва да посетя хиляди уеб страници, за да съставя списъка на членовете. Това очевидно би било безумно предложение.
За щастие съм съавтор на VBA и макроси за Microsoft Excel. Чудех се дали мога да персонализирам кода от книгата, за да реша проблема с извличането на URL адреси на членове от хиляди свързани страници.
Глава 14 на книгата е за използването на Excel за четене и писане в мрежата. На страница 335 намерих код, който може да създаде уеб заявка в движение.
Първата стъпка беше да проверя дали мога да персонализирам кода в книгата, за да мога да създам 27 уеб заявки - по една за всяка от буквите на азбуката и цифрата 1. Това ще ми даде няколко списъка с всички връзки в 26 списъка на азбучни страници.
Всяка страница има URL, подобен на http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Взех код от страница 335 и го персонализирах малко, за да направя 27 уеб заявки.
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Имаше четири елемента, които бяха персонализирани в горния код.
- Първо, трябваше да изградя правилния URL адрес. Това беше постигнато чрез добавяне на правилното писмо в края на низа на URL адреса.
- Второ, модифицирах кода, за да стартирам всяка заявка на нов работен лист в работната книга.
- Трето, кодът в книгата грабваше 20-тата таблица от уеб страницата. Записвайки макро издърпване в таблицата от PMA, научих, че имам нужда от 7-ма таблица на уеб страницата.
- Четвърто, след като стартирах макроса, с разочарование видях, че получавам имената на издателите, но не и хипервръзките. Кодът в книгата е посочен .WebFormatting: = xlFormattingNone. Използвайки помощта на VBA, разбрах, че ако се променя на .WebFormatting: = xlFormattingAll, ще получа действителните хипервръзки.
След стартирането на този първи макрос имах 27 работни листа, всеки с поредица от хипервръзки, които изглеждаха така:
Следващата стъпка беше да извлечете хипервръзния адрес от всяка хипервръзка на 27-те работни листа. Няма го в книгата, но в Excel има обект на хипервръзка. Обектът има свойство .Address, което ще върне уеб страницата в PMA-Online с 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След като стартирах този макрос, най-накрая научих, че на сайта на PMA има 4119 отделни уеб страници. Радвам се, че не се опитах да посетя всеки отделен сайт един по един!
Следващата ми цел беше да създам уеб заявка, която да посети всяка от 4119 отделни уеб страници. Записах макрос, връщащ една от отделните страници на издателя, за да науча, че искам таблица №5 от всяка страница. Видях, че името на издателя е върнато като петия ред на таблицата. В повечето случаи уебсайтът беше върнат като 13-ти ред. Разбрах обаче, че в някои случаи, ако адресът на улицата е бил 3 реда вместо 2, URL адресът на уебсайта всъщност е бил на ред 14. Ако те са имали 3 телефона вместо 2, уебсайтът е бил изместен с друг ред надолу. Макросът ще трябва да бъде достатъчно гъвкав, за да търси от може би ред 13 до 18, за да намери клетката, която е стартирала WWW :.
Имаше и друга дилема. Кодът в книгата позволява на уеб заявката да се опресни във фонов режим. В повечето случаи всъщност бих наблюдавал завършването на заявката след приключване на макроса. Първоначалната ми мисъл беше да разреша 40 реда за всеки издател и да изградя всички 4100 заявки на всяка страница. Това би изисквало 80 000 реда електронна таблица и много памет. В Excel 2002 експериментирах с промяна на BackgroundRefresh на False. VBA се справи добре с изтеглянето на информацията в работния лист, преди макросът да продължи. Това може да бъде за изграждане на заявката, опресняване на заявката, запазване на стойностите в база данни, след което изтриване на заявката. Използвайки този метод, на работния лист никога не е имало повече от една заявка наведнъж.
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Изпълнението на тази заявка отне повече от час. В края на краищата той вършеше работата по посещението на над 4000 уеб страници. Той работи без проблеми и не срива компютъра или Excel.
След това имах хубава база данни в Excel с име на издател в колона А и уебсайт в колона Б. След сортирането по уебсайт в колона Б установих, че над 1000 издатели не са посочили уебсайт. Вписването им в колона Б е празен URL адрес. Сортирах и изтрих тези редове.
Също така уебсайтовете, изброени в колона Б, са имали „WWW:“ преди всеки URL адрес. Използвах Edit> Replace, за да променя всяко появяване на WWW: (с интервал след него) на нищо. Имах хубав списък с 2339 издатели в електронна таблица.
Последната стъпка беше да напишете текстов файл, който да може да бъде копиран и поставен в уебсайта на всеки член. Следващият макрос (адаптиран от кода на страница 345) се справи добре с тази задача.
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Резултатът беше текстов файл с името и URL адреса на 2000+ издатели.
Всички горепосочени кодове са адаптирани от книгата. Когато започнах, просто правех еднократна програма, която не предвиждах да се изпълнява редовно. Сега обаче мога да изобразявам връщане към уебсайта на PMA всеки месец или така, за да получа актуализираните списъци с URL адреси.
Би било възможно всички горепосочени стъпки да бъдат поставени в един макрос.
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 и VBA предоставиха бърза алтернатива на индивидуалното посещение на хиляди уеб страници. На теория PMA е трябвало да може да прави заявки към тяхната база данни и да предоставя тази информация много по-бързо, отколкото да използва този метод. Понякога обаче имате работа с някой, който не сътрудничи или евентуално не знае как да извлече данни от база данни, която някой друг е написал за тях. В този случай малко VBA макро код реши проблема ни.
