Использование веб-запросов и цикла для загрузки 4000 записей базы данных с 4000 веб-страниц - Советы по Excel

Содержание

Однажды я получил электронное письмо от Яна из PMA. Она передавала отличную идею от Гэри Гальярди из Clearbridge Publishing. Гэри упомянул, что некоторые поисковые системы присваивают странице рейтинг страницы в зависимости от того, сколько других сайтов ссылаются на эту страницу. Он предполагал, что, если все 4000 членов PMA будут связаны со всеми 4000 других членов PMA, это повысит все наши рейтинги. Ян подумал, что это отличная идея, и сказал, что все веб-адреса членов PMA перечислены на текущем веб-сайте PMA в зоне для членов.

Лично я считаю, что теория «числа ссылок» - это немного миф, но я был готов попробовать, чтобы помочь.

Итак, я посетил зону для членов PMA, где я быстро узнал, что не было единого списка членов, а на самом деле 27 списков членов.

Я посетил зону для членов PMA.

Когда я перешел на страницу «А», я увидел, что это еще хуже. Каждая ссылка на этой странице не ведет на сайт участника. Каждая ссылка здесь ведет на отдельную страницу в 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 листов, каждый с серией гиперссылок, которые выглядели так:

Извлеченные ссылки с гиперссылками в Excel.

Следующим шагом было извлечение адреса с гиперссылкой из каждой гиперссылки на 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 с именем издателя в столбце A и веб-сайтом в столбце B. После сортировки по веб-сайтам в столбце B я обнаружил, что более 1000 издателей не указали веб-сайты. Их запись в столбце B была пустым URL. Я отсортировал и удалил эти строки.

Кроме того, веб-сайты, перечисленные в столбце B, имели перед каждым URL-адресом «WWW:». Я использовал 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 Sub

Excel и VBA предоставили быструю альтернативу индивидуальному посещению тысяч веб-страниц. Теоретически PMA должен был иметь возможность запрашивать свою базу данных и предоставлять эту информацию гораздо быстрее, чем при использовании этого метода. Однако иногда вы имеете дело с кем-то, кто отказывается сотрудничать или, возможно, не знает, как получить данные из базы данных, которую кто-то написал для него. В этом случае небольшая часть кода макроса VBA решила нашу проблему.

Интересные статьи...