如何从多个页面中提取车辆列表？

Question

美好的一天 - 这是我之前帖子的后续，但我觉得自从有人回答我无法对其进行进一步更新，所以我创建了一个新帖子来解决不同的问题。 我正在使用 VBA 阅读 Craigslist Miami 的汽车清单。该代码可以很好地打印每辆车和价格的链接。唯一的问题是当我选择不同的城市时，例如洛杉矶，URL 语法发生变化，我不确定如何阅读类名。下面的代码适用于迈阿密链接（在代码中），但不适用于此链接： https://losangeles.craigslist.org/search/cta#search=1~list~1~0

Sub newandoptimized()

Dim link As HTMLLinkElement
Dim blog As HTMLLinkElement
Dim price As HTMLLinkElement
Dim IE As Object
Dim html  As HTMLDocument
Dim URL As String
Dim URLParameter As String
Dim page As Long, counter As Long
'Dim http As Object
Dim links As Object
Dim blogpost As Object
Dim priceonly As Object
Dim StartCell As Range
Dim increment As Integer
Dim htmlele1 As HTMLLinkElement
 Dim ss As Integer
   Dim ee As Integer


    

' This is the first cell that a blog post hyperlink is created in
Set StartCell = Range("A1")

URL = "https://miami.craigslist.org/search/cta"
Set IE = CreateObject("InternetExplorer.Application")

Application.ScreenUpdating = True

' CHnage this to False if you want to hide IE
IE.Visible = True

counter = 0
page = 0


 
 'Set the number of pages of the website to go through in the browser
For page = 0 To 480 Step 120  'increment by 120 - total 4 pages
  ' Debug.Print page
   
   If page >= 0 Then URLParameter = "?s=" & page

  IE.navigate URL & URLParameter
    
     'Wait for the browser to load the page
    Do Until IE.readyState = 4
    
        DoEvents
        
    Loop

    Set html = IE.document
    Set links = html.getElementsByTagName("h3")
    Index = 0

    For Each link In links
                        
        If InStr(LCase(link.outerHTML), "result-heading") Then
    
            Set blogpost = link.getElementsByTagName("a")
            Set priceonly = link.getElementsByClassName("result-price")
            Set Results = html.getElementsByClassName("result-row")
            For Each blog In blogpost
                        
                StartCell.Offset(counter, 0).Hyperlinks.Add _
                Anchor:=StartCell.Offset(counter, 0), Address:=blog, _
                TextToDisplay:=link.innerText
                
                StartCell.Offset(counter, 1).Value = Results(Index).getElementsByTagName("span")(0).innerText
                                      
                  Index = Index + 1
            Next blog
            
           counter = counter + 1
            
        End If
    
    Next link
            
    Next page

   IE.Quit
   Set IE = Nothing
   

Columns("B:B").Select
            Selection.NumberFormat = "$#,##0.00"
            Columns("D:D").Select
            Selection.NumberFormat = "m/d/yyyy;@"

 End Sub

Answer 1

[编辑：现在已经更新并且可以正常工作。 LA 很难，因为 CL 使用所有 JS 来加载他们的网站。 Internet Explorer 在受支持时并不出色，从那以后它只会变得更糟。我已经包含了一些 hacky 技巧来使其工作。你不配合就不行，你不配合就回来抱怨不行我也帮不了你。所以，请一起玩，并按照说明进行操作。另外......在你接受它作为答案后，这值得投票。]

我是linking in your original question，另一个用户在那里重新创建了您的迈阿密解决方案，这样如果其他人无意中发现了这个，他们就可以了解背景故事。

对于新的洛杉矶城市 URL 格式，请尝试以下代码。我已经修改了设置 URLParameter 变量值的行并添加了一个单独的计数器以避免过多地改变循环。一旦你测试了它以确保它有效，你应该尝试将这个版本与上一个版本进行比较并尝试理解如何有用。如有必要，请随时在 cmets 中提问。

Option Explicit
'REQUIRED REFERENCES
'requires ref to Microsoft HTML Object Library
'requires ref to Microsoft Internet Controls
''In your IDE Menu (Alt + F11 to open), see Tools>References

Sub ScrapeMiami()
''Note that CraigsList does NOT like it when
''commercial entities scrape their websites.
''They have sued people in the past and won.
''You probably shouldn't be scraping them, so
''this script is for educational purposes only.
''Any use of this script is at your own risk.
Dim IE As Object
Dim AllHTML  As HTMLDocument
Dim URL As String
Dim URLParameter As String
Dim Result As Long
Dim PageOfResults As Long
Dim StartCell As Range
Dim CurrentRow As Long

Dim ResultPrice As String
Dim ResultTitle As String
Dim ResultLink As String
Dim ResultDateTemp As String
Dim ResultDate As Date
Dim AllResults As IHTMLElementCollection
Dim AllLinks As IHTMLElementCollection
Dim AllPrices As IHTMLElementCollection
Dim AllTitles As IHTMLElementCollection
Dim AllDates As IHTMLElementCollection

''Date Strings to convert from Int'l Std to MS format
Dim strYear As String
Dim strMonth As String
Dim strDay As String

''Class Name Targets
Dim ClassForResults As String
Dim ClassForLinks As String
Dim ClassForTitles As String
Dim ClassForPrices As String
Dim ClassForDates As String

''Initialize Class Name Targets
ClassForResults = "result-row" ''used for indexing
ClassForLinks = "result-title hdrlnk"
ClassForTitles = "result-title hdrlnk"
ClassForPrices = "result-price"
ClassForDates = "result-date"

''This is the first cell to which a search result is written
Set StartCell = Range("A1")

''Change these to False if you want to hide Excel and/or IE
''If you do hide Excel and/or IE, don't forget to set them back to True at the end
Application.ScreenUpdating = True
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True

''Initialize counter for Excel
CurrentRow = 0

''Explain errors if they occur
On Error GoTo ErrorHandler

''Set the number of pages of the website to go through in the browser
For PageOfResults = 0 To 480 Step 120  ''increment by 120 - total 4 pages
    
    URL = "https://miami.craigslist.org/search/cta"
    URLParameter = "?s=" & PageOfResults
    
    ''Navigate to page then wait for IE to load the page before continuing
    IE.navigate URL & URLParameter
    Do Until IE.readyState = 4
        DoEvents
    Loop
    
    Set AllHTML = IE.document
    Set AllResults = AllHTML.getElementsByClassName(ClassForResults)
    If AllResults.Length > 0 Then
        For Result = 0 To AllResults.Length - 1
            ''This next bit is verbose so that you can easily fix it on your own without help
            ''if something changes in the future.
            Set AllLinks = AllResults(Result).getElementsByClassName(ClassForLinks)
            ResultLink = AllLinks.Item(0).getAttribute("href")
            Set AllPrices = AllResults(Result).getElementsByClassName(ClassForPrices)
            ResultPrice = AllPrices.Item(0).innerText
            Set AllTitles = AllResults(Result).getElementsByClassName(ClassForTitles)
            ResultTitle = AllTitles.Item(0).innerText
            Set AllDates = AllResults(Result).getElementsByClassName(ClassForDates)
            ResultDateTemp = Left(AllDates.Item(0).getAttribute("datetime"), 10)
            strYear = Mid(ResultDateTemp, 1, 4)
            strMonth = Mid(ResultDateTemp, 6, 2)
            strDay = Mid(ResultDateTemp, 9, 2)
            ''This will cause a fight on StackOverflow, but I didn't choose the MS date format.
            ''Doing this allows MS to autolocalize the date format by sysref in Excel.
            ResultDate = DateValue(strMonth & "/" & strDay & "/" & strYear)
            
            ''Add the current result to the Excel spreadsheet
            With Worksheets(1)
                .Hyperlinks.Add _
                Anchor:=StartCell.Offset(CurrentRow, 0), _
                Address:=ResultLink, _
                TextToDisplay:=ResultTitle                          ''link and title in column A
                StartCell.Offset(CurrentRow, 1).Value = ResultPrice ''Price in column B
                StartCell.Offset(CurrentRow, 2).Value = ResultDate  ''Date in column C
            End With
            CurrentRow = CurrentRow + 1
        Next Result
    Else
        GoTo UnusualError
    End If
Next PageOfResults

''clean up objects
IE.Quit
Set IE = Nothing

''format data as desired in Excel
Columns("B:B").Select
Selection.NumberFormat = "$#,##0.00"
Columns("C:C").Select
Selection.NumberFormat = "m/d/yyyy;@"

''unhide Excel just in case it's hidden
Application.ScreenUpdating = True
Exit Sub

''explain any errors along the way
UnusualError:
    MsgBox ("No error was detected, but no search results were detected." & vbNewLine _
    & "Check the HTML output to see if it changed or do some debugging.")
    Exit Sub

ErrorHandler:
    MsgBox ("Error" & Err.Number & " on line " & Erl & vbNewLine & Err.Description)

End Sub

这里是洛杉矶

Option Explicit
'REQUIRED REFERENCES
'requires ref to Microsoft HTML Object Library
'requires ref to Microsoft Internet Controls
''In your IDE Menu (Alt + F11 to open), see Tools>References

Sub ScrapeLosAngeles()
''Note that CraigsList does NOT like it when
''commercial entities scrape their websites.
''They have sued people in the past and won.
''You probably shouldn't be scraping them, so
''this script is for educational purposes only.
''Any use of this script is at your own risk.
Dim IE As InternetExplorer
Dim AllHTML  As HTMLDocument

Dim URL As String
Dim URLParameter As String
Dim Result As Long
Dim PageOfResults As Long
Dim StartCell As Range
Dim CurrentRow As Long

Dim ResultPrice As String
Dim ResultTitle As String
Dim ResultLink As String
Dim ResultDateTemp As String
Dim ResultDate As Date
Dim AllResults As IHTMLElementCollection
Dim AllLinks As IHTMLElementCollection
Dim AllPrices As IHTMLElementCollection
Dim AllTitles As IHTMLElementCollection
Dim AllDates As IHTMLElementCollection
Dim MetaElement As Long
Dim SearchIn As String
Dim SearchFor As String

''Date Strings to convert from Int'l Std to MS format
Dim strYear As String
Dim strMonth As String
Dim strDay As String

''Class Name Targets
Dim ClassForResults As String
Dim ClassForLinks As String
Dim ClassForTitles As String
Dim ClassForPrices As String
Dim ClassForDates As String

''Initialize Class Name Targets
ClassForResults = "cl-result-info single-line" ''used for indexing
ClassForLinks = "titlestring"
ClassForTitles = "titlestring"
ClassForPrices = "priceinfo"
ClassForDates = "meta" ''need to drill down further to find tag with title attribute containing "Time"

''This is the first cell to which a search result is written
Set StartCell = Range("A1")

''Change these to False if you want to hide Excel and/or IE
''If you do hide Excel and/or IE, don't forget to set them back to True at the end
Application.ScreenUpdating = True
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True

''Initialize counter for Excel
CurrentRow = 0

''Explain errors if they occur
On Error GoTo ErrorHandler

''Set the number of pages of the website to go through in the browser
''Note that LA page does not increment results the way Miami increments results
For PageOfResults = 0 To 4
    
    URL = "https://losangeles.craigslist.org/search/cta"
    'customized URLParameter for los angeles URL format
    URLParameter = "#search=1~list~" & PageOfResults & "~0"
    
    ''Navigate to page then wait for IE to load the page before continuing
    IE.navigate URL & URLParameter
    
    Do Until IE.readyState = 4
        DoEvents
    Loop
    ''giving IE some extra time on the first load to avoid reading data too early
    If PageOfResults = 0 Then
        Application.Wait (10)
    End If
    
    Set AllHTML = IE.document
    
    ''Leave this in. It tricks Excel into waiting without a "Wait" call.
    Debug.Print AllHTML.readyState
    
    ''More waiting -- Don't skip this or remove it. I'll know, and so will you.
    If Not PageOfResults = 0 Then
        MsgBox ("Do not click OK until you can see that IE is finished loading." & vbNewLine _
    & "It's an old browser, and Craig's List uses a LOT of javascript. It takes time." & vbNewLine _
    & "I STRONGLY recommend that you Alt-Tab between the Excel spreadsheet and IE until" & vbNewLine _
    & "you see the next popup like this one. IE will close when this script finishes.")
    End If
    
    ''And now back to regularly scheduled programming.
    Set AllResults = AllHTML.getElementsByClassName(ClassForResults)
    If AllResults.Length > 0 Then
        For Result = 0 To AllResults.Length - 1
            
            ''This next bit is verbose so that you can easily fix it on your own without help
            ''if something changes in the future.
            Set AllLinks = AllResults(Result).getElementsByClassName(ClassForLinks)
            ResultLink = AllLinks.Item(0).getAttribute("href")
            Set AllPrices = AllResults(Result).getElementsByClassName(ClassForPrices)
            
            ''Not all listings in LA have a price; this If/Else avoids errors when that happens
            If AllPrices.Length < 1 Then
                ResultPrice = "No Price Listed"
            Else
                ResultPrice = AllPrices.Item(0).innerText
            End If
            Set AllTitles = AllResults(Result).getElementsByClassName(ClassForTitles)
            ResultTitle = AllTitles.Item(0).innerText
            Set AllDates = AllResults(Result).getElementsByTagName("span")
            
            ''LA Dates are slightly hidden -- below is how we find them
            ''If the HTML format changes, this might change too
            For MetaElement = 0 To AllDates.Length - 1
                If Not AllDates(MetaElement).getAttribute("title") = "" Then
                    SearchIn = AllDates(MetaElement).getAttribute("title")
                    SearchFor = "Time"
                    If InStr(SearchIn, SearchFor) > 0 Then
                        ResultDateTemp = AllDates(MetaElement).getAttribute("title")
                        Exit For ''break us out of the for loop when we find our date indicator
                    End If
                End If
            Next MetaElement
            If Len(ResultDateTemp) < 15 Then
                MsgBox ("The Formatting didn't work for the date. Something may have changed.")
                Exit Sub
            End If
            ResultDateTemp = Left(ResultDateTemp, 15)
            strYear = Mid(ResultDateTemp, 12, 4)
            strMonth = Mid(ResultDateTemp, 5, 3)
            strDay = Mid(ResultDateTemp, 9, 2)
            
            ''This will cause a fight on StackOverflow, but I didn't choose the MS date format.
            ''Changing Date format allows MS to autolocalize the date format by sysref in Excel.
            ResultDate = DateValue(strMonth & " " & strDay & ", " & strYear)
            
            ''Add the current result to the Excel spreadsheet
            With Worksheets(1)
                .Hyperlinks.Add Anchor:=StartCell.Offset(CurrentRow, 0), Address:=ResultLink, TextToDisplay:=ResultTitle
                StartCell.Offset(CurrentRow, 1).Value = ResultPrice ''Price in column B
                StartCell.Offset(CurrentRow, 2).Value = ResultDate  ''Date in column C
            End With
            CurrentRow = CurrentRow + 1
        Next Result
    Else
        GoTo UnusualError
    End If
Next PageOfResults

''clean up objects
IE.Quit
Set IE = Nothing

''format data as desired in Excel
Columns("B:B").Select
Selection.NumberFormat = "$#,##0.00"
Columns("C:C").Select
Selection.NumberFormat = "m/d/yyyy;@"

''unhide Excel just in case it's hidden
Application.ScreenUpdating = True
Exit Sub

''explain any errors along the way
UnusualError:
    MsgBox ("No error was detected, but no search results were detected either." & vbNewLine _
    & "Reset and try it again. If you see the same error, check the HTML output for changes." & vbNewLine _
    & "Be patient. The script does work when IE works.")
    Exit Sub

ErrorHandler:
    MsgBox ("Error " & Err.Number & " on line " & Erl & vbNewLine & Err.Description & vbNewLine & Err.Source)

End Sub