Menggunakan Kueri Web dan Loop untuk Mengunduh 4000 Entri Database dari 4000 Halaman Web - Tips Excel

Daftar Isi

Suatu hari, saya menerima email siaran dari Jan di PMA. Dia menyampaikan ide bagus dari Gary Gagliardi dari Clearbridge Publishing. Gary menyebutkan bahwa beberapa mesin pencari menetapkan peringkat halaman ke halaman berdasarkan berapa banyak situs lain yang menautkan ke halaman tersebut. Dia menyarankan bahwa jika semua 4000 anggota PMA akan terhubung ke 4000 anggota PMA lainnya, itu akan meningkatkan semua peringkat kami. Jan merasa ini adalah ide yang bagus dan mengatakan bahwa semua alamat web anggota PMA terdaftar di situs web PMA saat ini di area anggota.

Secara pribadi, saya pikir teori "jumlah tautan" adalah sedikit mitos, tetapi saya bersedia mencobanya untuk membantu.

Jadi, saya mengunjungi area Anggota PMA, di mana saya dengan cepat mengetahui bahwa tidak ada satu daftar anggota, tetapi sebenarnya 27 daftar anggota.

Saya mengunjungi area Anggota PMA.

Saat saya mengklik ke halaman "A", saya melihat bahwa itu bahkan lebih buruk. Setiap tautan di halaman ini tidak mengarah ke situs web anggota. Setiap tautan di sini mengarah ke halaman individu di PMA-online dengan situs web anggota.

Tautan di halaman web.

Ini berarti saya harus mengunjungi ribuan halaman web untuk mengumpulkan daftar anggota. Ini jelas akan menjadi proposisi yang gila.

Untungnya, saya adalah rekan penulis VBA & Macros untuk Microsoft Excel. Saya bertanya-tanya apakah saya dapat menyesuaikan kode dari buku untuk memecahkan masalah mengekstrak URL anggota dari ribuan halaman yang ditautkan.

Bab 14 buku ini membahas tentang penggunaan Excel untuk membaca dari dan menulis ke web. Pada halaman 335, saya menemukan kode yang dapat membuat kueri web dengan cepat.

Langkah pertama adalah melihat apakah saya dapat menyesuaikan kode di buku agar dapat menghasilkan 27 kueri web - satu untuk setiap huruf alfabet dan angka 1. Ini akan memberi saya beberapa daftar dari semua tautan di 26 daftar halaman alfabetis.

Setiap halaman memiliki URL yang mirip dengan http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Saya mengambil kode dari halaman 335 dan menyesuaikannya sedikit untuk melakukan 27 kueri web.

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

Ada empat item yang disesuaikan pada kode di atas.

  • Pertama, saya harus membuat URL yang benar. Ini dicapai dengan menambahkan huruf yang tepat ke akhir string URL.
  • Kedua, saya memodifikasi kode untuk menjalankan setiap kueri pada lembar kerja baru di buku kerja.
  • Ketiga, kode di buku itu meraih tabel ke-20 dari halaman web. Dengan merekam makro yang menarik tabel dari PMA, saya mengetahui bahwa saya memerlukan tabel ke-7 di halaman web.
  • Keempat, setelah menjalankan makro, saya kecewa karena saya mendapatkan nama penerbitnya, tetapi tidak mendapatkan hyperlinknya. Kode dalam buku ditentukan .WebFormatting: = xlFormattingNone. Dengan menggunakan bantuan VBA, saya membayangkan bahwa jika saya berubah menjadi .WebFormatting: = xlFormattingAll, saya akan mendapatkan hyperlink yang sebenarnya.

Setelah menjalankan makro pertama ini, saya memiliki 27 lembar kerja, masing-masing dengan serangkaian hyperlink yang terlihat seperti ini:

Tautan yang diekstrak dengan hyperlink di Excel.

Langkah selanjutnya adalah mengekstrak alamat hyperlink dari setiap hyperlink di 27 lembar kerja. Ini tidak ada di dalam buku, tapi ada objek hyperlink di Excel. Objek tersebut memiliki properti .Address yang akan mengembalikan halaman web dalam PMA-Online dengan URL untuk penerbit itu.

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

Setelah menjalankan makro ini, saya akhirnya mengetahui bahwa ada 4119 halaman web individu di situs PMA. Saya senang bahwa saya tidak mencoba mengunjungi setiap situs satu per satu!

Tujuan saya berikutnya adalah memiliki webquery yang dibangun untuk mengunjungi masing-masing 4119 halaman web individual. Saya mencatat makro yang mengembalikan salah satu laman penerbit individual untuk mengetahui bahwa saya menginginkan tabel # 5 dari setiap laman. Saya dapat melihat bahwa nama penerbit dikembalikan sebagai baris kelima dari tabel. Dalam banyak kasus, situs web ditampilkan sebagai baris ke-13. Namun, saya mengetahui bahwa dalam beberapa kasus, jika alamat jalan adalah 3 baris, bukan 2, URL situs web sebenarnya ada di baris 14. Jika mereka memiliki 3 telepon, bukan 2, situs web tersebut didorong ke baris lain. Makro harus cukup fleksibel untuk mencari dari barangkali baris 13 sampai 18 untuk menemukan sel yang memulai WWW :.

Ada dilema lain. Kode dalam buku memungkinkan webquery disegarkan di latar belakang. Dalam kebanyakan kasus, saya benar-benar akan melihat kueri selesai setelah makro selesai. Pikiran awal saya adalah mengizinkan 40 baris untuk setiap penerbit, dan membangun semua 4100 kueri di setiap halaman. Ini akan membutuhkan 80.000 baris spreadsheet dan banyak memori. Di Excel 2002, saya bereksperimen dengan mengubah BackgroundRefresh menjadi False. VBA melakukan pekerjaan yang baik dengan menarik informasi ke dalam lembar kerja sebelum makro dilanjutkan. Ini diperbolehkan untuk membuat kueri, menyegarkan kueri, menyimpan nilai ke database, lalu menghapus kueri. Dengan menggunakan metode ini, tidak pernah ada lebih dari satu kueri sekaligus di lembar kerja.

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

This query took more than an hour to run. After all, it was doing the work of visiting over 4000 web pages. It did run without a hitch and did not crash the computer or Excel.

I then had a nice database in Excel with Publisher name in column A and the website in column B. After sorting by website in Column B, I found that over 1000 publishers did not list a web site. Their entry in column B was a blank URL. I sorted and deleted these rows.

Also, the websites listed in column B had "WWW: " before each URL. I used a Edit> Replace to change each occurence of WWW: (with a space after it) to nothing. I had a nice list of 2339 publishers on a spreadsheet.

Publishers list on the spreadsheet.

The last step was to write out a text file that could be copied and pasted into any members' website. The following macro (adapted from the code on page 345) handled this task nicely.

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

The result was a text file with the name and URL of 2000+ publishers.

All of the above code was adapted from the book. When I started, I was sort of just doing a one-off program that I didn't envision running regularly. However, I can now imaging going back to the PMA website every month or so to get the updated lists of URL's.

It would be possible to put all of the above steps into a single macro.

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 and VBA provided a quick alternative to individually visiting thousands of web pages. In theory, the PMA should have been able to query their database and provide this information far more quickly than using this method. However, sometimes you are dealing with someone who is uncooperative or possibly doesn't know how to get data out of a database that someone else wrote for them. In this case, a bit of VBA macro code solved our problem.

Artikel yang menarik...