VBA网页爬取报“Subscript out of range”错误求助（适配新站点）

Let's break down why you're hitting that "Subscript out of range" error and fix it step by step.

Root Cause of the Error #

The error on ReDim results(1 To rowCount, 1 To numColumns) occurs because rowCount = listings.Length returns 0. This means your selector .main li[class] isn't matching any elements on the Stormore site—even though the sites look visually similar, their underlying HTML structure has changed just enough to break your query.

Key Fixes & Improvements #

Here's how to resolve the issue and make your code more robust:

1. Update the Listings Selector
   Open the Stormore site in Chrome/Firefox, right-click a storage unit, and select "Inspect". You'll find the units are nested inside a container with class unit-list, and each unit is an li with class unit-item. Replace your original selector with this targeted one.

2. Add Safeguards for Empty Results
   If no listings are found (for example, if the selector is wrong), we'll add a check to avoid the subscript error entirely.

3. Fix Selector Scope & Add Null Checks
   You were accidentally using the main html document instead of html2 for the description field, which would have caused inconsistent results. We'll also add null checks for every element query to prevent runtime errors if a unit is missing certain fields.

Updated Working Code #

Option Explicit
Public Sub GetInfo()
    Dim ws As Worksheet, html As HTMLDocument, s As String
    Const URL As String = "https://www.stormore.net/self-storage-seattle-wa-101616#utm_source=GoogleLocal&utm_medium=WRLocal&utm_campaign=101616"
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set html = New HTMLDocument
    
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        s = .responseText
        html.body.innerHTML = s
    End With
    
    Dim headers(), results(), listings As Object, amenities As String
    headers = Array("Size", "Description", "Amenities", "Offer1", "Offer2", "RateType", "Price")
    
    ' Updated selector for Stormore's storage unit listings
    Set listings = html.querySelectorAll(".unit-list li.unit-item")
    
    Dim rowCount As Long, numColumns As Long, r As Long, c As Long
    Dim icons As Object, icon As Long, amenitiesInfo(), i As Long, item As Long
    rowCount = listings.Length
    numColumns = UBound(headers) + 1
    
    ' Safeguard: Exit if no listings are found to avoid subscript error
    If rowCount = 0 Then
        MsgBox "No storage units found. Please verify your selector!", vbExclamation
        Exit Sub
    End If
    
    ReDim results(1 To rowCount, 1 To numColumns)
    Dim html2 As HTMLDocument
    Set html2 = New HTMLDocument
    
    For item = 0 To listings.Length - 1
        r = r + 1
        html2.body.innerHTML = listings.item(item).innerHTML
        
        ' Size field with null check
        If Not html2.querySelector(".size") Is Nothing Then
            results(r, 1) = Trim$(html2.querySelector(".size").innerText)
        End If
        
        ' Fixed: Use html2 (not main html) to get unit-specific description
        If Not html2.querySelector(".description") Is Nothing Then
            results(r, 2) = Trim$(html2.querySelector(".description").innerText)
        End If
        
        ' Amenities collection
        Set icons = html2.querySelectorAll("i[title]")
        If icons.Length > 0 Then
            ReDim amenitiesInfo(0 To icons.Length - 1)
            For icon = 0 To icons.Length - 1
                amenitiesInfo(icon) = icons.item(icon).getAttribute("title")
            Next
            amenities = Join$(amenitiesInfo, ", ")
        Else
            amenities = "No amenities listed"
        End If
        results(r, 3) = amenities
        
        ' Offer and pricing fields with null checks
        If Not html2.querySelector(".offer1") Is Nothing Then
            results(r, 4) = html2.querySelector(".offer1").innerText
        End If
        If Not html2.querySelector(".offer2") Is Nothing Then
            results(r, 5) = html2.querySelector(".offer2").innerText
        End If
        If Not html2.querySelector(".rate-label") Is Nothing Then
            results(r, 6) = html2.querySelector(".rate-label").innerText
        End If
        If Not html2.querySelector(".price") Is Nothing Then
            results(r, 7) = html2.querySelector(".price").innerText
        End If
    Next
    
    ' Write headers and results to worksheet
    ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
    ws.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

内容的提问来源于stack exchange，提问作者kiran mamalwad