VBA实现多日期网站天气数据爬取并写入Excel求助

Hey there! As a fellow VBA learner, I totally get where you're coming from—scraping data and getting it into Excel can feel tricky at first. Let's break down your two problems and build a solution that works for you.

Your current code prints results to the Immediate Window, which is great for testing, but we need to redirect that data to worksheet cells. Here's the plan:

• Track the row number where we'll write data (start at row 2, assuming row 1 is for headers)
• Split the Temp.Title string into temperature, station name, and time (since your output follows the pattern 7.4°C | Wien-Mariabrunn (225m) | 14:00)
• Write each component to the corresponding column (A for date, B for time, C for temperature + station)

To batch fetch data from a start date to end date, we'll:

• Define your target date range
• Loop through each date, format it to match the URL's YYYYMMDD pattern
• Plug the formatted date into the URL (along with your desired time, e.g., 1300z)
• Repeat the scraping process for every date in the range

Full Working Code #

Here's a complete, commented version of the code that addresses both issues:

Sub ScrapeWeatherData()
    Dim xmlReq As MSXML2.XMLHTTP60
    Dim HTMLDoc As MSHTML.HTMLDocument
    Dim Temps1 As MSHTML.IHTMLElementCollection
    Dim temps2 As MSHTML.IHTMLElementCollection
    Dim Temp As MSHTML.IHTMLElement
    Dim startDate As Date, endDate As Date, currentDate As Date
    Dim rowNum As Long
    Dim urlDatePart As String
    Dim dataParts() As String
    
    ' Set your desired date range here (adjust these values to your needs)
    startDate = DateSerial(2019, 1, 1)
    endDate = DateSerial(2019, 1, 3)
    rowNum = 2 ' Start writing data from row 2 (row 1 is for headers)
    
    ' Add column headers to your worksheet
    With ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your actual sheet name
        .Cells(1, 1).Value = "Date"
        .Cells(1, 2).Value = "Time"
        .Cells(1, 3).Value = "Temperature & Station"
    End With
    
    ' Loop through each date in the defined range
    currentDate = startDate
    Do While currentDate <= endDate
        ' Format the current date to match the URL's YYYYMMDD pattern
        urlDatePart = Format(currentDate, "YYYYMMDD")
        
        ' Initialize XML and HTML objects for each request
        Set xmlReq = New MSXML2.XMLHTTP60
        Set HTMLDoc = New MSHTML.HTMLDocument
        
        ' Send the HTTP request to the target URL
        xmlReq.Open "GET", "https://kachelmannwetter.com/at/messwerte/wien/temperatur/" & urlDatePart & "-1300z.html", False
        xmlReq.send
        
        ' Check if the request was successful
        If xmlReq.Status = 200 Then
            HTMLDoc.body.innerHTML = xmlReq.responseText
            
            ' Grab elements from both target classes
            Set Temps1 = HTMLDoc.getElementsByClassName("ap o o-1 o-tmp-5")
            Set temps2 = HTMLDoc.getElementsByClassName("ap o o-1 o-tmp-1")
            
            ' Process elements from Temps1
            For Each Temp In Temps1
                ' Split the title string into individual components
                dataParts = Split(Temp.Title, " | ")
                
                ' Write data to the worksheet
                With ThisWorkbook.Sheets("Sheet1")
                    .Cells(rowNum, 1).Value = currentDate ' Date in column A
                    .Cells(rowNum, 2).Value = dataParts(2) ' Time in column B
                    .Cells(rowNum, 3).Value = dataParts(0) & " | " & dataParts(1) ' Temp + Station in column C
                End With
                rowNum = rowNum + 1 ' Move to the next empty row
            Next Temp
            
            ' Process elements from temps2
            For Each Temp In temps2
                dataParts = Split(Temp.Title, " | ")
                With ThisWorkbook.Sheets("Sheet1")
                    .Cells(rowNum, 1).Value = currentDate
                    .Cells(rowNum, 2).Value = dataParts(2)
                    .Cells(rowNum, 3).Value = dataParts(0) & " | " & dataParts(1)
                End With
                rowNum = rowNum + 1
            Next Temp
        Else
            ' Log error details if the request fails
            With ThisWorkbook.Sheets("Sheet1")
                .Cells(rowNum, 1).Value = currentDate
                .Cells(rowNum, 2).Value = "Error"
                .Cells(rowNum, 3).Value = "Request failed: " & xmlReq.Status & " - " & xmlReq.statusText
            End With
            rowNum = rowNum + 1
        End If
        
        ' Clean up objects to avoid memory leaks
        Set xmlReq = Nothing
        Set HTMLDoc = Nothing
        Set Temps1 = Nothing
        Set temps2 = Nothing
        
        ' Move to the next date in the range
        currentDate = DateAdd("d", 1, currentDate)
    Loop
    
    MsgBox "Data scraping complete!", vbInformation
End Sub

Key Tips for Your Workflow #

• References: Ensure you've enabled references to Microsoft XML, v6.0 and Microsoft HTML Object Library (go to Tools > References in the VBA editor to check)
• Sheet Customization: Replace "Sheet1" with your actual worksheet name
• Time Flexibility: If you need to scrape multiple times per day (not just 1300z), add an inner loop for different time values (e.g., 1000z, 1400z) and adjust the URL accordingly
• Formatting: After scraping, format column A as dates and column B as time in Excel for better readability

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