Sử dụng truy vấn web và vòng lặp để tải xuống 4000 mục nhập cơ sở dữ liệu từ 4000 trang web - Mẹo Excel

Mục lục

Một ngày nọ, tôi nhận được một email quảng cáo từ Jan tại PMA. Cô ấy đã truyền đạt một ý tưởng tuyệt vời từ Gary Gagliardi của Nhà xuất bản Clearbridge. Gary đã đề cập rằng một số công cụ tìm kiếm chỉ định thứ hạng trang cho một trang dựa trên số lượng các trang web khác liên kết đến trang đó. Ông ấy đã gợi ý rằng nếu tất cả 4000 thành viên của PMA liên kết với tất cả 4000 thành viên khác của PMA, thì điều đó sẽ tăng thứ hạng của chúng ta. Jan nghĩ đây là một ý tưởng tuyệt vời và nói rằng tất cả các địa chỉ web của thành viên PMA đều được liệt kê trên trang web hiện tại của PMA trong khu vực thành viên.

Cá nhân tôi nghĩ lý thuyết "số lượng liên kết" hơi hoang đường, nhưng tôi sẵn sàng thử nó để giúp đỡ.

Vì vậy, tôi đã đến thăm khu vực Thành viên PMA, nơi tôi nhanh chóng biết rằng không có một danh sách thành viên nào, mà trên thực tế là 27 danh sách thành viên.

Tôi đã đến thăm khu vực Thành viên PMA.

Khi tôi nhấp qua trang "A", tôi thấy rằng nó thậm chí còn tồi tệ hơn. Mỗi liên kết trên trang này không dẫn đến trang web của thành viên. Mỗi liên kết ở đây dẫn đến một trang riêng lẻ tại PMA-trực tuyến với trang web của thành viên.

Các liên kết trong trang web.

Điều này có nghĩa là tôi sẽ phải truy cập hàng nghìn trang web để tổng hợp danh sách các thành viên. Đây rõ ràng sẽ là một đề xuất điên rồ.

May mắn thay, tôi là đồng tác giả của VBA & Macros cho Microsoft Excel. Tôi tự hỏi liệu tôi có thể tùy chỉnh mã từ cuốn sách để giải quyết vấn đề trích xuất URL của thành viên từ hàng nghìn trang được liên kết hay không.

Chương 14 của cuốn sách nói về việc sử dụng Excel để đọc và ghi lên web. Trên trang 335, tôi đã tìm thấy mã có thể tạo truy vấn web nhanh chóng.

Bước đầu tiên là xem liệu tôi có thể tùy chỉnh mã trong sách để có thể tạo ra 27 truy vấn web - một cho mỗi chữ cái trong bảng chữ cái và số 1. Điều này sẽ cung cấp cho tôi một số danh sách tất cả các liên kết trên 26 danh sách trang theo thứ tự bảng chữ cái.

Mỗi trang có một URL tương tự như http://www.pma-online.org/scripts/showmemlist.cfm?letter=A. Tôi lấy mã từ trang 335 và tùy chỉnh nó một chút để thực hiện 27 truy vấn 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

Có bốn mục đã được tùy chỉnh trong đoạn mã trên.

Đầu tiên, tôi phải xây dựng URL chính xác. Điều này đạt được bằng cách thêm ký tự thích hợp vào cuối chuỗi URL.
Thứ hai, tôi đã sửa đổi mã để chạy từng truy vấn trên một trang tính mới trong sổ làm việc.
Thứ ba, mã trong cuốn sách đã lấy bảng thứ 20 từ trang web. Bằng cách ghi lại một macro kéo trong bảng từ PMA, tôi biết được rằng tôi cần bảng thứ 7 trên trang web.
Thứ tư, sau khi chạy macro, tôi thất vọng khi thấy rằng tôi nhận được tên của các nhà xuất bản, nhưng không phải các siêu liên kết. Mã trong sách đã chỉ định .WebFormatting: = xlFormattingNone. Sử dụng trợ giúp của VBA, tôi nhận ra rằng nếu tôi thay đổi thành .WebFormatting: = xlFormattingAll, tôi sẽ nhận được các siêu liên kết thực tế.

Sau khi chạy macro đầu tiên này, tôi có 27 trang tính, mỗi trang tính có một loạt các siêu liên kết trông như thế này:

Trích xuất liên kết với siêu liên kết trong Excel.

Bước tiếp theo là trích xuất địa chỉ siêu kết nối từ mọi siêu kết nối trên 27 trang tính. Nó không có trong sách, nhưng có một đối tượng siêu kết nối trong Excel. Đối tượng có thuộc tính .Address sẽ trả về trang web trong PMA-Online với URL cho nhà xuất bản đó.

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

Sau khi chạy macro này, cuối cùng tôi biết được rằng có 4119 trang web riêng lẻ tại trang PMA. Tôi rất vui vì tôi đã không cố gắng truy cập từng trang riêng lẻ một!

Mục tiêu tiếp theo của tôi là xây dựng một truy vấn web để truy cập từng trang trong số 4119 trang web riêng lẻ. Tôi đã ghi lại một macro trả về một trong các trang của nhà xuất bản riêng lẻ để biết rằng tôi muốn có bảng số 5 từ mỗi trang. Tôi có thể thấy rằng tên nhà xuất bản đã được trả lại ở hàng thứ năm của bảng. Trong hầu hết các trường hợp, trang web được trả về ở hàng thứ 13. Tuy nhiên, tôi biết được rằng trong một số trường hợp, nếu địa chỉ đường phố là 3 dòng thay vì 2, thì URL của trang web thực sự ở hàng 14. Nếu họ có 3 điện thoại thay vì 2, trang web đã bị đẩy xuống một hàng khác. Macro sẽ phải đủ linh hoạt để tìm kiếm có lẽ từ hàng 13 đến 18 để tìm ô bắt đầu WWW :.

Có một tình huống khó xử khác. Mã trong sách cho phép truy vấn web làm mới trong nền. Trong hầu hết các trường hợp, tôi thực sự sẽ xem truy vấn kết thúc sau khi macro kết thúc. Suy nghĩ ban đầu của tôi là cho phép 40 hàng cho mỗi nhà xuất bản và tạo tất cả 4100 truy vấn trên mỗi trang. Điều này sẽ yêu cầu 80.000 hàng bảng tính và rất nhiều bộ nhớ. Trong Excel 2002, tôi đã thử nghiệm với việc thay đổi BackgroundRefresh thành False. VBA đã làm tốt việc kéo thông tin vào trang tính trước khi macro hoạt động. Điều này được phép xây dựng truy vấn, làm mới truy vấn, lưu các giá trị vào cơ sở dữ liệu, sau đó xóa truy vấn. Sử dụng phương pháp này, không bao giờ có nhiều hơn một truy vấn cùng một lúc trên trang tính.

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

Truy vấn này mất hơn một giờ để chạy. Rốt cuộc, nó đang thực hiện công việc truy cập hơn 4000 trang web. Nó đã chạy mà không gặp trở ngại và không làm hỏng máy tính hoặc Excel.

Sau đó, tôi có một cơ sở dữ liệu đẹp trong Excel với tên Nhà xuất bản ở cột A và trang web ở cột B. Sau khi sắp xếp theo trang web trong Cột B, tôi thấy rằng hơn 1000 nhà xuất bản không liệt kê một trang web. Mục nhập của họ trong cột B là một URL trống. Tôi đã sắp xếp và xóa các hàng này.

Ngoài ra, các trang web được liệt kê trong cột B có "WWW:" trước mỗi URL. Tôi đã sử dụng Chỉnh sửa> Thay thế để thay đổi mỗi lần xuất hiện của WWW: (có dấu cách sau nó) thành không. Tôi đã có một danh sách tuyệt đẹp gồm 2339 nhà xuất bản trên một bảng tính.

Danh sách nhà xuất bản trên bảng tính.

Bước cuối cùng là viết một tệp văn bản có thể sao chép và dán vào trang web của bất kỳ thành viên nào. Macro sau đây (được điều chỉnh từ mã trên trang 345) đã xử lý tốt tác vụ này.

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

Kết quả là một tệp văn bản có tên và URL của hơn 2000 nhà xuất bản.

Tất cả các đoạn mã trên đều được chuyển thể từ cuốn sách. Khi tôi bắt đầu, tôi chỉ thực hiện một chương trình duy nhất mà tôi không hình dung là sẽ chạy thường xuyên. Tuy nhiên, bây giờ tôi có thể quay lại trang web PMA hàng tháng hoặc lâu hơn để nhận danh sách cập nhật của URL.

Có thể đặt tất cả các bước trên vào một macro duy nhất.

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 và VBA cung cấp một giải pháp thay thế nhanh chóng cho việc truy cập riêng lẻ hàng nghìn trang web. Về lý thuyết, PMA lẽ ra có thể truy vấn cơ sở dữ liệu của họ và cung cấp thông tin này nhanh hơn nhiều so với việc sử dụng phương pháp này. Tuy nhiên, đôi khi bạn đang đối phó với một người bất hợp tác hoặc có thể không biết cách lấy dữ liệu ra khỏi cơ sở dữ liệu mà người khác đã viết cho họ. Trong trường hợp này, một chút mã macro VBA đã giải quyết được vấn đề của chúng tôi.