Використання веб-запитів та циклу для завантаження 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

Запустивши цей макрос, я нарешті дізнався, що на сайті РМА є 4119 окремих веб-сторінок. Я радий, що не намагався відвідувати кожен окремий сайт по одному!

Моєю наступною метою було створення веб-запиту для відвідування кожної з 4119 окремих веб-сторінок. Я записав макрос, що повертає одну зі сторінок видавця, щоб дізнатися, що мені потрібна таблиця №5 з кожної сторінки. Я бачив, що ім’я видавця було повернуто як п’ятий рядок таблиці. У більшості випадків веб-сайт повертали як 13-й рядок. Однак я довідався, що в деяких випадках, якщо адреса вулиці складала 3 рядки замість 2, URL-адреса веб-сайту фактично знаходилася в рядку 14. Якщо у них було 3 телефони замість 2, веб-сайт було висунуто ще на один рядок. Макрос повинен бути достатньо гнучким для пошуку з, можливо, рядків 13 до 18, щоб знайти комірку, яка розпочала WWW :.

Була ще одна дилема. Код у книзі дозволяє веб-запиту оновлюватися у фоновому режимі. У більшості випадків я б фактично спостерігав за завершенням запиту після завершення макросу. Моя початкова думка полягала в тому, щоб дозволити 40 рядків для кожного видавця та побудувати всі 4100 запитів на кожній сторінці. Для цього знадобилося б 80000 рядків електронних таблиць і багато пам'яті. В 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:". Я використав "Редагувати> Замінити", щоб змінити кожну появу 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 вирішило нашу проблему.

Цікаві статті...