vba抓取网页数据

功能实现：自动计算国庆期间在个个城市停留的时间（乱码转码，html截取、日历、下拉，两个网站：携程和火车票网）

Function getTrainInfo_ctrip(rowNum)
    
    If Range("A" & rowNum).Value = "" Then
        Range("B" & rowNum & ":C" & rowNum).Delete
        Exit Function
    End If
    Dim strRespText$, tt$
    Dim URL
    URL = "https://trains.ctrip.com/trainbooking/TrainSchedule/" & Range("A" & rowNum).Value
    'Debug.Print URL
    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", URL, False                     '要抓取的链接，"GET"尽量用大写，以免某些系统不兼容
        .Send
        
        Index = InStr(.responsetext, "<div id=""ctl00_MainContentPlaceHolder_pnlResult"">")
        If Index <= 0 Then
            Range("B" & rowNum & ":C" & rowNum).Delete
            Range("B" & rowNum) = "查无此车"
            Exit Function
        End If
        
        tt = Mid(.responsetext, Index)
        Index2 = InStr(tt, "ctl00_MainContentPlaceHolder_divStartAndEndSchedule")
        tt = Left(tt, Index2 - 44)
        
        'Set fs = CreateObject("Scripting.FileSystemObject")
        'Set a = fs.CreateTextFile("D:\Document\excel\log.txt", True)
        'a.write (tt)
        'a.Close
    End With
    
    Set oDom = CreateObject("htmlfile")
    oDom.body.innerHTML = tt
    
    'Debug.Print oDom.getElementById("ctl00_MainContentPlaceHolder_pnlResult").innerText
    Set oTbody = oDom.getElementById("ctl00_MainContentPlaceHolder_pnlResult").getElementsByTagName("div")(2).getElementsByTagName("table")(1).getElementsByTagName("tbody")(0)
    'Debug.Print oTbody.innerText
    'Debug.Print oTbody.Rows.Length
    
    Dim allCity As String
    allCity = ""
    'Integer String
    Dim startPlace, endPlace As Integer
    startPlace = 0
    endPlace = 0
    'Debug.Print Range("B" & rowNum).Value
    
    If Range("B" & rowNum).Value = "" Then
            Range("B" & rowNum) = oTbody.Rows(0).Cells(2).innerText
    End If
    If Range("C" & rowNum).Value = "" Then
        Range("C" & rowNum) = oTbody.Rows(oTbody.Rows.Length - 1).Cells(2).innerText
    End If

    For i = 1 To oTbody.Rows.Length
        allCity = allCity & "," & oTbody.Rows(i - 1).Cells(2).innerText
        'Debug.Print oTbody.Rows(i - 1).Cells(2).innerText
        'Debug.Print InStr(Range("B" & rowNum).Value, oTbody.Rows(i - 1).Cells(2).innerText)
        
        If startPlace = 0 And InStr(Range("B" & rowNum).Value, oTbody.Rows(i - 1).Cells(2).innerText) > 0 Then
            startPlace = i
            'Debug.Print startPlace
        End If
        
        If endPlace = 0 And InStr(Range("C" & rowNum).Value, oTbody.Rows(i - 1).Cells(2).innerText) > 0 Then
            endPlace = i
            'Debug.Print endPlace
        End If
        
    Next
    
    If startPlace = 0 Then
        Range("B" & rowNum) = oTbody.Rows(0).Cells(2).innerText
        startPlace = 1
    End If
    
    If endPlace = 0 Then
        Range("C" & rowNum) = oTbody.Rows(oTbody.Rows.Length - 1).Cells(2).innerText
        endPlace = oTbody.Rows.Length
    End If
    
    Set oSelect = Range("B" & rowNum & ":C" & rowNum)
    With oSelect.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=allCity
    End With
    
    Range("D" & rowNum) = oTbody.Rows(startPlace - 1).Cells(4).innerText
    Range("E" & rowNum) = oTbody.Rows(endPlace - 1).Cells(4).innerText
    
End Function
'http://search.huochepiao.com/checi/C7140
Function getTrainInfo_huochepiao(rowNum)
    
    If Range("A" & rowNum).Value = "" Then
        Range("C" & rowNum & ":D" & rowNum).Delete
        Exit Function
    End If
    If Range("B" & rowNum).Value = "" Then
        Range("B" & rowNum) = Date
    End If
    Dim strRespText$, tt$
    Dim URL
    URL = "http://search.huochepiao.com/checi/" & Range("A" & rowNum).Value
    'Debug.Print URL
    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", URL, False                     '要抓取的链接，"GET"尽量用大写，以免某些系统不兼容
        .Send
        
        tt = .responsetext
        With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")    'DataObject对象，数据放入剪贴板，记事本观察数据
            .SetText tt                                                    '因为XMLHTTP默认是UTF-8，不能识别gb2312，会发现数据乱码
            .PutInClipboard                                                '所以不能采用.responsetext对象来得到字符串
        End With
        tt = StrConv(.ResponseBody, vbUnicode)
        
        Index = InStr(tt, "</table><br><table border=")
        If Index <= 0 Then
            Range("C" & rowNum & ":D" & rowNum).Delete
            Range("C" & rowNum) = "查无此车"
            Exit Function
        End If
        tt = Mid(tt, Index + 12)
        Index2 = InStr(tt, "</td></tr></table>")
        tt = Left(tt, Index2 + 18)
        
        'Debug.Print tt
        
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set a = fs.CreateTextFile("D:\Document\excel\log.txt", True)
        a.write (tt)
        a.Close
        
    End With
    
    Set oDom = CreateObject("htmlfile")
    oDom.body.innerHTML = tt
    
    Set oTbody = oDom.getElementsByTagName("td")

    'Debug.Print oTbody.Length
    '84-
    'Debug.Print oTbody(14).innerText
    
    Dim allCity As String
    allCity = ""
    'Integer String
    Dim startPlace, endPlace As Integer
    startPlace = 0
    endPlace = 0
    'Debug.Print Range("C" & rowNum).Value
    
    Dim startNum, stepNum, endCityDataNum As Integer
    If oTbody(9).innerText = "硬座" Then
        startNum = 15
        stepNum = 13
        endCityDataNum = 11
    ElseIf oTbody(9).innerText = "硬卧上/中/下" Or oTbody(9).innerText = "商务座" Then
        startNum = 14
        stepNum = 12
        endCityDataNum = 10
    Else
        Exit Function
    End If
    If Range("C" & rowNum).Value = "" Then
            Range("C" & rowNum) = oTbody(startNum).innerText
    End If
    If Range("D" & rowNum).Value = "" Then
        Range("D" & rowNum) = oTbody(oTbody.Length - endCityDataNum).innerText
    End If
    
    'Debug.Print "startNum"; startNum; "oTbody.Length"; oTbody.Length
    For i = startNum To oTbody.Length Step stepNum
        allCity = allCity & "," & oTbody(i).innerText
        'Debug.Print oTbody(i).innerText
        'Debug.Print InStr(Range("C" & rowNum).Value, oTbody.Rows(i - 1).Cells(2).innerText)
        
        If startPlace = 0 And InStr(Range("C" & rowNum).Value, oTbody(i).innerText) > 0 Then
            startPlace = i
            'Debug.Print startPlace
        End If
        
        If endPlace = 0 And InStr(Range("D" & rowNum).Value, oTbody(i).innerText) > 0 Then
            endPlace = i
            'Debug.Print endPlace
        End If
        
    Next
    
    If startPlace = 0 Then
        Range("C" & rowNum) = oTbody(startNum).innerText
        startPlace = startNum
    End If
    
    If endPlace = 0 Then
        Range("D" & rowNum) = oTbody(oTbody.Length - endCityDataNum).innerText
        endPlace = oTbody.Length - endCityDataNum
    End If
    
    Set oSelect = Range("C" & rowNum & ":D" & rowNum)
    With oSelect.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=allCity
    End With
    
    
    Range("E" & rowNum) = Range("B" & rowNum).Value & " " & oTbody(startPlace + 2).innerText

    Dim startUseTime, endUseTime As Integer
    
    Dim s
    Dim midString As String

    If InStr(oTbody(startPlace + 4).innerText, "小时") > 0 Then
        midString = Replace(oTbody(startPlace + 4).innerText, "小时", ":")
        s = Split(Replace(midString, "分", ""), ":")
        startUseTime = s(0) * 60 + s(1)
        
    Else
        startUseTime = Replace(oTbody(startPlace + 4).innerText, "分", "")
    End If
    
    If InStr(oTbody(endPlace + 4).innerText, "小时") > 0 Then
        midString = Replace(oTbody(endPlace + 4).innerText, "小时", ":")
        s = Split(Replace(midString, "分", ""), ":")
        endUseTime = s(0) * 60 + s(1)
    Else
        endUseTime = Replace(oTbody(endPlace + 4).innerText, "分", "")
    End If
    
    'Debug.Print startUseTime
    'Debug.Print endUseTime
    'Debug.Print Range("E" & rowNum).Value
    'Debug.Print Format$(CDate((endUseTime - startUseTime) / 1440 + CDate(Range("E" & rowNum).Value)), "yyyy-mm-dd hh:mm:ss")
    Range("F" & rowNum) = Format$(CDate((endUseTime - startUseTime) / 1440 + CDate(Range("E" & rowNum).Value)), "yyyy-mm-dd hh:mm:ss")
    
End Function
Sub test()
    Range("B" & 1) = "查询中、、、"
    'getTrainInfo_huochepiao (10)
    For i = 3 To 20
        getTrainInfo_huochepiao (i)
    Next
    
    Range("B" & 1) = "查询完毕"
End Sub

效果截图：（求偶遇哈哈！！！）

源文档已经上传：https://download.csdn.net/download/struggletolife/11723002