用 Excel VBA 採集鉅亨網 CRB 歷史資料

今天早上寫出來的，只有基本功能。

Sheet1:

Private Sub CommandButton_Update_Click()
    Dim lDate As Date
    If IsDate(Worksheets("CRB").Range("A3").Value) Then
        lDate = Worksheets("CRB").Range("A3").Value
    Else
        lDate = initDate
    End If
    Dim res As Variant
    Dim d As Date
    For d = lDate To Date
        res = getCRBWebData(d)
        If IsNumeric(res) Then
            Worksheets("CRB").Rows(3).Insert
            Worksheets("CRB").Range("B3").Value = res
            Worksheets("CRB").Range("A3").Value = d
        Else
            'MsgBox "not numeric"
        End If
    Next d
End Sub

Module1:

Public Const initDate = #1/1/1996#
Sub myDebug()
    Worksheets("CRB").Activate
    ActiveSheet.Range("B1") = findLastDataDate
End Sub
Function findLastDataDate()
    findLastDataDate = Date
End Function
Function getCRBWebData(TargetDate As Date)
    ' add a temporary worksheet
    Sheets.Add
    Sheets(1).Name = "Temp"
    Sheets("Temp").Move After:=Sheets("CRB")
    Sheets("Temp").Activate
    ' getWebData Macro
    ' 抓取網路 CRB 資料
    Dim StrData As String
    StrData = Format(TargetDate, "yyyymmdd")
    Application.StatusBar = "URL;http://www.cnyes.com/futures/History.aspx?mydate=" & StrData & "&code=CRBCON"
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.cnyes.com/futures/History.aspx?mydate=" & StrData & "&code=CRBCON", _
        Destination:=Range("A1"))
        .Name = "History.aspx?mydate=" & StrData & "&code=CRBCON"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
    ' copy data to worksheet("CRB")
    If IsNumeric(Worksheets("Temp").Range("A2")) Then
        'Worksheets("CRB").Range("A3") = Worksheets("Temp").Range("A2")
        getCRBWebData = Worksheets("Temp").Range("A2")
    Else
        'MsgBox "目前無資料"
        getCRBWebData = Null
    End If
    ' delete temporary worksheet
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
End Function