(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

Dylan67 wrote:
圖二是手動加入巨集命令後修改圖標的方式，我不想用自帶的圖標，可是我找不到添加圖標的路徑

Dylan67 wrote:
在Test2運行時判斷是否源自Test1呼叫，可是我不想用K變量來做判斷

Sub test()
    Dim Sub_name As String: Sub_name = "test"
    Call Name_test(Sub_name)
End Sub

Sub test99()
    Dim Sub_name As String: Sub_name = "test99"
    Call Name_test(Sub_name)
End Sub

Sub test2()
    Call Name_test
End Sub


Sub Name_test(Optional Sub_name As String = "other sub")
    MsgBox Sub_name
End Sub

rainbowsperm wrote:
也可以跟XMLHTTP的方式一樣只擷取某個特定的table嗎? 像最後一個? 還是要所有資料一次parse?

g80860 wrote:
我要如何著手或想法寫出程式碼

Public Set_time As Double
Public DB As Object
Public RS As Object
Public check As String
Public LastRow As Double



Sub Start_test()

    Set DB = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.Path & "\testdata.accdb" & ";"
    
    Columns("F:H").ClearContents
    Columns("F:H").NumberFormatLocal = "@"
    Range("a2:c2").NumberFormatLocal = "@"
    Range("f1:h1") = Array("time", "max", "min")
    LastRow = 2
    
    Call Write_Simulation_data
    
    
End Sub

Sub Stop_test()
    
    On Error Resume Next
    Application.OnTime earliesttime:=Set_time, procedure:="Write_Simulation_data", schedule:=False
    
    check = ""
    RS.Close
    DB.Close
    Set RS = Nothing
    Set DB = Nothing
    
    On Error GoTo 0
    
End Sub

Sub Write_Simulation_data()
    
    Dim sql As String
    
    '==Simulation==
    Randomize
    Range("a2") = Range("a2") + 1
    Range("b2") = Format(Now(), "hhmm")
    Range("c2") = WorksheetFunction.Round((150 - 5 + 1) * Rnd() + 5, 3)
    '===============
    
    If check = "" Then check = Range("b2")
    
    sql = "'" & Range("a2") & "','" & Format(Now(), "yyyymmdd") & "','" & Range("b2") & "','" & Range("c2") & "'"
    DB.Execute = "INSERT INTO 資料表1 ([index],[day],[time],[price]) VALUES (" & sql & ")"
    
    Set_time = Now + TimeValue("00:00:01")
    Application.OnTime Set_time, "Write_Simulation_data"

    If check <> Range("b2") Then
        Call Read_Simulation_data
        check = Range("b2")
    End If
    
End Sub

Sub Read_Simulation_data()
    
    'Debug.Print check
    
    Dim sql As String

    sql = "SELECT max(price),min(price) from 資料表1 WHERE time='" & check & "'" & " and day='" & Format(Now(), "yyyymmdd") & "'"
    RS.Open sql, DB, 3, 3
    
    If RS.RecordCount <> 0 Then
        Cells(LastRow, 6) = check
        Cells(LastRow, 7).CopyFromRecordset RS
        LastRow = LastRow + 1
    End If
    
    RS.Close
    
End Sub