Menggunakan Pertanyaan Web dan Gelung untuk memuat turun 4000 Entri Pangkalan Data dari 4000 Halaman Web - Petua Excel

Isi kandungan

Suatu hari, saya menerima e-mel siaran dari Jan di PMA. Dia menyampaikan idea hebat dari Gary Gagliardi dari Clearbridge Publishing. Gary menyebut bahawa beberapa mesin pencari menetapkan peringkat halaman ke halaman berdasarkan berapa banyak laman web lain yang menghubungkan ke halaman tersebut. Dia mencadangkan bahawa jika semua 4000 anggota PMA akan menghubungkan ke semua 4000 anggota PMA yang lain, itu akan meningkatkan semua peringkat kami. Jan berpendapat bahawa ini adalah idea yang bagus dan mengatakan bahawa semua alamat web ahli PMA disenaraikan di laman web PMA semasa di kawasan ahli.

Secara peribadi, saya fikir teori "jumlah pautan" agak mitos, tetapi saya bersedia mencubanya untuk membantu.

Oleh itu, saya mengunjungi kawasan Ahli PMA, di mana saya dengan cepat mengetahui bahawa tidak ada satu senarai ahli, tetapi sebenarnya 27 senarai ahli.

Saya mengunjungi kawasan Ahli PMA.

Semasa saya mengklik ke halaman "A", saya melihat bahawa ia lebih buruk lagi. Setiap pautan di halaman ini tidak menuju ke laman web ahli. Setiap pautan di sini membawa ke halaman individu di PMA-dalam talian dengan laman web ahli.

Pautan di laman web.

Ini bermaksud bahawa saya harus mengunjungi beribu-ribu laman web untuk menyusun senarai ahli. Ini jelas akan menjadi cadangan yang tidak waras.

Nasib baik, saya adalah pengarang bersama VBA & Makro untuk Microsoft Excel. Saya tertanya-tanya adakah saya dapat menyesuaikan kod dari buku untuk menyelesaikan masalah pengekstrakan URL ahli dari ribuan halaman yang dipautkan.

Bab 14 buku ini adalah mengenai penggunaan Excel untuk membaca dan menulis ke web. Di halaman 335, saya menemui kod yang dapat membuat pertanyaan web dengan cepat.

Langkah pertama adalah untuk melihat apakah saya dapat menyesuaikan kod dalam buku untuk dapat menghasilkan 27 pertanyaan web - satu untuk setiap huruf abjad dan nombor 1. Ini akan memberi saya beberapa senarai semua pautan di 26 senarai halaman abjad.

Setiap halaman mempunyai URL yang serupa dengan http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Saya mengambil kod dari halaman 335 dan menyesuaikannya sedikit untuk melakukan 27 pertanyaan 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

Terdapat empat item yang disesuaikan dalam kod di atas.

  • Pertama, saya harus membina URL yang betul. Ini dicapai dengan menambahkan huruf yang tepat di hujung rentetan URL.
  • Kedua, saya mengubah kod untuk menjalankan setiap pertanyaan pada lembaran kerja baru di buku kerja.
  • Ketiga, kod dalam buku itu mengambil jadual ke-20 dari laman web. Dengan merakam makro menarik jadual dari PMA, saya mengetahui bahawa saya memerlukan jadual ke-7 di laman web.
  • Keempat, setelah menjalankan makro, saya kecewa melihat bahawa saya mendapat nama penerbit, tetapi bukan hyperlink. Kod dalam buku yang ditentukan .WebFormatting: = xlFormattingNone. Dengan menggunakan bantuan VBA, saya menyangka bahawa jika saya menukar ke.

Setelah menjalankan makro pertama ini, saya mempunyai 27 lembaran kerja, masing-masing dengan rangkaian pautan yang kelihatan seperti ini:

Pautan yang diekstrak dengan pautan hiper di Excel.

Langkah seterusnya adalah mengekstrak alamat hyperlink dari setiap hyperlink pada 27 lembaran kerja. Itu bukan dalam buku, tetapi ada objek hyperlink di Excel. Objek tersebut mempunyai properti .Address yang akan mengembalikan halaman web dalam PMA-Online dengan URL untuk penerbit tersebut.

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 bahawa terdapat 4119 laman web individu di laman PMA. Saya gembira kerana saya tidak mencuba untuk mengunjungi setiap laman web satu per satu!

Tujuan saya seterusnya adalah membina webquery untuk mengunjungi setiap 4119 halaman web individu. Saya merakam makro yang mengembalikan salah satu halaman penerbit individu untuk mengetahui bahawa saya mahukan jadual # 5 dari setiap halaman. Saya dapat melihat bahawa nama penerbit dikembalikan sebagai baris kelima jadual. Dalam kebanyakan kes, laman web dikembalikan sebagai baris ke-13. Walau bagaimanapun, saya mengetahui bahawa dalam beberapa kes, jika alamat jalan adalah 3 baris dan bukannya 2, URL laman web sebenarnya berada di baris 14. Sekiranya mereka mempunyai 3 telefon dan bukannya 2, laman web itu diturunkan ke baris lain. Makro harus cukup fleksibel untuk mencari dari barisan 13 hingga 18 untuk mencari sel yang memulakan WWW:.

Terdapat dilema lain. Kod dalam buku membolehkan permintaan web disegarkan di latar belakang. Dalam kebanyakan kes, saya sebenarnya akan melihat pertanyaan selesai setelah makro selesai. Pemikiran awal saya adalah membenarkan 40 baris untuk setiap penerbit, dan membina semua 4100 pertanyaan di setiap halaman. Ini memerlukan 80,000 baris spreadsheet dan banyak memori. Di Excel 2002, saya bereksperimen dengan mengubah BackgroundRefresh menjadi False. VBA melakukan tugas yang baik dengan menarik maklumat ke dalam lembaran kerja sebelum makro diteruskan. Ini diizinkan untuk membangun pertanyaan, menyegarkan pertanyaan, menyimpan nilai ke pangkalan data, kemudian menghapus pertanyaan. Dengan menggunakan kaedah ini, tidak ada lebih daripada satu pertanyaan pada satu masa pada lembaran 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

Pertanyaan ini mengambil masa lebih dari satu jam untuk dijalankan. Bagaimanapun, ia membuat lawatan ke lebih dari 4000 laman web. Ia berjalan tanpa halangan dan tidak merosakkan komputer atau Excel.

Saya kemudian mempunyai pangkalan data yang bagus di Excel dengan nama Penerbit di lajur A dan laman web di lajur B. Setelah menyusun mengikut laman web di Lajur B, saya mendapati lebih daripada 1000 penerbit tidak menyenaraikan laman web. Catatan mereka di lajur B adalah URL kosong. Saya menyusun dan memadamkan baris ini.

Juga, laman web yang disenaraikan dalam lajur B mempunyai "WWW:" sebelum setiap URL. Saya menggunakan Edit> Ganti untuk mengubah setiap kejadian WWW: (dengan spasi selepasnya) menjadi sia-sia. Saya mempunyai senarai 2339 penerbit yang bagus dalam hamparan.

Senarai penerbit di hamparan.

Langkah terakhir adalah menulis fail teks yang dapat disalin dan ditampal ke laman web mana-mana ahli. Makro berikut (diadaptasi dari kod di halaman 345) menangani tugas ini dengan baik.

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

Hasilnya adalah fail teks dengan nama dan URL 2000+ penerbit.

Semua kod di atas diadaptasi dari buku. Semasa saya memulakan, saya seperti melakukan program sekali sahaja yang tidak saya sangka berjalan secara berkala. Walau bagaimanapun, saya kini dapat mengimbas kembali ke laman web PMA setiap bulan atau lebih untuk mendapatkan senarai URL yang dikemas kini.

Adalah mungkin untuk memasukkan semua langkah di atas ke dalam satu makro.

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 dan VBA memberikan alternatif pantas untuk mengunjungi beribu-ribu laman web secara individu. Secara teori, PMA seharusnya dapat menanyakan pangkalan data mereka dan memberikan maklumat ini jauh lebih cepat daripada menggunakan kaedah ini. Walau bagaimanapun, kadang-kadang anda berurusan dengan seseorang yang tidak bekerjasama atau mungkin tidak tahu bagaimana mengeluarkan data dari pangkalan data yang ditulis oleh orang lain untuk mereka. Dalam kes ini, sedikit kod makro VBA menyelesaikan masalah kami.

Artikel menarik...