Једног дана, примио сам е-маил од Јана на ПМА. Преносила је сјајну идеју од Гарија Гаглиардија из Цлеарбридге Публисхинга. Гари је напоменуо да неки претраживачи додељују ранг страници страници на основу броја других сајтова који воде до странице. Сугерисао је да би, ако би се свих 4000 чланова ПМА повезало са свих 4000 других чланова ПМА, то повећало све наше ранг-листе. Јан је сматрао да је ово добра идеја и рекао је да су све веб адресе чланова ПМА наведене на тренутној веб локацији ПМА у подручју за чланове.
Лично мислим да је теорија „броја веза“ помало мит, али био сам спреман да покушам да бих јој помогао.
Дакле, посетио сам подручје чланова ПМА, где сам брзо сазнао да не постоји ниједна листа чланова, већ заправо 27 листа чланова.
Кад сам кликнуо на страницу „А“, видео сам да је то још горе. Свака веза на овој страници није водила до веб странице члана. Свака веза овде води до појединачне странице на ПМА-онлине са веб страницом члана.
То би значило да бих морао да посетим хиљаде веб страница да бих саставио списак чланова. Ово би очигледно био сулуд предлог.
Срећом, коаутор сам ВБА и макронаредби за Мицрософт Екцел. Питао сам се да ли бих могао да прилагодим код из књиге како бих решио проблем издвајања УРЛ-ова чланова са хиљада повезаних страница.
14. поглавље књиге говори о коришћењу програма Екцел за читање са Интернета и писање на њега. На страници 335 пронашао сам код који би могао да креира веб упит у ходу.
Први корак је био да видим могу ли прилагодити код из књиге како бих могао да произведем 27 веб упита - по један за свако слово абецеде и број 1. То би ми дало неколико листа свих веза на 26 абецедних пописа страница.
Свака страница има УРЛ сличан хттп://ввв.пма-онлине.орг/сцриптс/сховмемлист.цфм?леттер=А. Узео сам код са странице 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У горњем коду биле су прилагођене четири ставке.
- Прво сам морао да направим тачан УРЛ. То је постигнуто додавањем одговарајућег слова на крај УРЛ-а.
- Друго, модификовао сам код да бих покренуо сваки упит на новом радном листу у радној свесци.
- Треће, код у књизи је хватао 20. табелу са веб странице. Снимањем макро увлачења у табелу са ПМА, сазнао сам да ми треба 7. табела на веб страници.
- Четврто, након покретања макроа, био сам разочаран када сам видео да добијам имена издавача, али не и хипервезе. Код у књизи је наведен .ВебФорматтинг: = клФорматтингНоне. Користећи помоћ ВБА, закључио сам да ћу, ако се променим у .ВебФорматтинг: = клФорматтингАлл, добити стварне хипервезе.
Након покретања овог првог макроа, имао сам 27 радних листова, сваки са низом хипервеза које су изгледале овако:
Следећи корак био је издвајање адресе хипервезе из сваке хипервезе на 27 радних листова. То није у књизи, али у програму Екцел постоји објекат хипервезе. Објект има својство .Аддресс које би вратило веб страницу у оквиру ПМА-Онлине са УРЛ-ом тог издавача.
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Након покретања овог макроа, коначно сам сазнао да је на веб локацији ПМА било 4119 појединачних веб страница. Драго ми је што нисам покушао да посећујем сваку појединачну страницу једну по једну!
Следећи циљ ми је био да направим веб-упит за посету свакој од 4119 појединачних веб-страница. Снимио сам макро који враћа једну од појединачних страница издавача да бих сазнао да желим табелу бр. 5 са сваке странице. Видео сам да је име издавача враћено као пети ред табеле. У већини случајева веб локација је враћена као 13. ред. Међутим, сазнао сам да је у неким случајевима, ако је адреса улице била 3 реда уместо 2, УРЛ веб локације заправо био у реду 14. Ако су имали 3 телефона уместо 2, веб локација је гурнута за други ред. Макро би морао бити довољно флексибилан за претрагу од можда 13. до 18. реда да би се пронашла ћелија која је покренула ВВВ :.
Постојала је још једна дилема. Код у књизи омогућава веб-упиту да се освежи у позадини. У већини случајева бих заправо гледао завршетак упита након завршетка макронаредбе. Моја почетна мисао је била да дозволим 40 редова за сваког издавача и да направим свих 4100 упита на свакој страници. За ово би било потребно 80.000 редова прорачунске табеле и пуно меморије. У програму Екцел 2002, експериментисао сам са променом БацкгроундРефресх-а у Фалсе. ВБА је добро обавио увлачење информација у радни лист пре него што се макро настави. То би могло бити стварање упита, освежавање упита, чување вредности у бази података, а затим брисање упита. Користећи ову методу, на радном листу никада није било више одједном упита.
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 веб страница. Покренуо се без проблема и није срушио рачунар или Екцел.
Тада сам имао лепу базу података у програму Екцел са именом издавача у колони А и веб локацију у колони Б. Након сортирања по веб локацији у колони Б, открио сам да преко 1000 издавача није наведло веб локацију. Њихов унос у колону Б био је празан УРЛ. Разврстао сам и избрисао ове редове.
Такође, веб локације наведене у колони Б имале су „ВВВ:“ пре сваке УРЛ адресе. Користио сам Едит> Реплаце да бих променио сваку појаву ВВВ: (са размаком након ње) у ништа. Имао сам леп списак од 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Резултат је била текстуална датотека са именом и УРЛ-ом више од 2000 издавача.
Сав наведени код је адаптиран из књиге. Када сам почео, некако сам само радио једнократни програм који нисам замишљао да се редовно покреће. Међутим, сада могу да снимим слике како се враћају на веб локацију ПМА сваког месеца или тако да бих добио ажуриране листе УРЛ-ова.
Било би могуће све наведене кораке ставити у један макро.
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Екцел и ВБА пружили су брзу алтернативу појединачном посећивању хиљада веб страница. У теорији, ПМА је требао бити у могућности да постави упит за њихову базу података и пружи ове информације много брже него коришћењем ове методе. Међутим, понекад имате посла са неким ко не сарађује или можда не зна како да извуче податке из базе података коју је неко други написао за њих. У овом случају, мало ВБА макро кода је решило наш проблем.
