hỏi cách lấy dữ liệu từ bảng giá chứng khoán trực tuyến trên web vào file excel

Liên hệ QC
Trang vcbs

Mã:
Public Sub hello(ByVal selectedStocks As String, ByVal criteriaId As String, ByVal pthMktId As String)
Dim str As String, payload As String, arr
'template Payload:{"selectedStocks":"AAM,ABT","criteriaId":"-11","marketId":0,"lastSeq":0,"isReqTL":false,"isReqMK":false,"tlSymbol":"","pthMktId":""}
payload = "{""selectedStocks"":""" & selectedStocks & """,""criteriaId"":""" & criteriaId & """,""marketId"":0,""lastSeq"":0," & _
"""isReqTL"":false,""isReqMK"":false,""tlSymbol"":"""",""pthMktId"":""" & pthMktId & """}"
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "POST", "http://quotes.vcbs.com.vn/PriceBoard/Acc/amw", False
    .setRequestHeader "Content-Type", "application/json"
    .send (payload)
    str = .ResponseText
End With
If Len(pthMktId) = 0 Then
    arr = tachBangGia(str)
Else
    arr = tachGDTT(str)
End If
Sheet1.Range("A5").Resize(UBound(arr) + 1000, UBound(arr, 2) + 50).ClearContents
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

Private Function tachBangGia(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, arr, dArr, dicColName As Object, r As Long
Dim rowData, cellData, c As Long, colIndex As Long
Dim regec As Object, mats As Object, mat As Object
Set dicColName = CreateObject("Scripting.Dictionary")
dicColName.CompareMode = vbTextCompare
arr = Array("SB", "CL", "FL", "RE", "B3", "V3", "B2", "V2", "B1", "V1", "CH", "CP", "CV", "S1", _
"U1", "S2", "U2", "S3", "U3", "TT", "OP", "HI", "LO", "FB", "FS", "FR")
For r = 0 To UBound(arr) Step 1
    dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachBangGia = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """f"":["))
lEnd = InStr(lStart, stResponse, "],")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 1), "\""", "")
arr = Split(stResponse, "Id:")

Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "[A-Z][A-Z0-9]\:[^,]*(,\d+)*"
'[A-Z][A-Z0-9]\:.*?(?=,[A-Z][A-Z0-9]\:)
regec.Global = True

For r = LBound(arr) + 1 To UBound(arr) Step 1
    Set mats = regec.Execute(arr(r))
    For Each mat In mats
        cellData = Split(mat, ":")
        If dicColName.exists(cellData(0)) Then
            colIndex = dicColName(cellData(0))
            dArr(r, colIndex) = IIf(CStr(cellData(1)) = "null", "", cellData(1))
        End If
    Next
Next
tachBangGia = dArr
End Function

Private Function tachGDTT(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, dicColName As Object, arr, dArr, r As Long
Dim colIndex As Long, rowData, colName As String, cellData, c As Long

Set dicColName = CreateObject("Scripting.Dictionary")
arr = Array("Symbol", "Price", "MatchVol", "fake", "Time")
For r = 0 To UBound(arr) Step 1
    dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachGDTT = dArr

lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """pm"":["))
lEnd = InStr(lStart, stResponse, "}]")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 2), """", "")
arr = Split(stResponse, "{Id:")

For r = LBound(arr) + 1 To UBound(arr) Step 1
    rowData = Split(arr(r), ",")
    For c = LBound(rowData) + 1 To UBound(rowData) Step 1
        lStart = InStr(1, rowData(c), ":")
        If lStart > 0 Then
            cellData = Mid(rowData(c), lStart + 1)
            colName = Left(rowData(c), lStart - 1)
            If dicColName.exists(colName) Then
                colIndex = dicColName(colName)
                If colIndex = 2 Then
                    dArr(r, colIndex) = cellData / 1000
                    dArr(r, 4) = "=RC[-2] * RC[-1]"
                Else
                    dArr(r, colIndex) = cellData
                End If
            End If
        End If
    Next
Next
tachGDTT = dArr
End Function

Public Function createVcbsList()
Dim arr(1 To 50, 1 To 4), curRow As Long, str As String
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "GET", "http://quotes.vcbs.com.vn/PriceBoard", False
    .send
    str = .ResponseText
End With

tachGroup str, arr, "HOSE", curRow
tachGroup str, arr, "HNX", curRow
tachGroup str, arr, "UPCOM", curRow
createVcbsList = arr
End Function

Private Sub tachGroup(ByVal stResponse As String, ByRef arr, groupName As String, ByRef curRow As Long)
Dim lStart As Long, lEnd As Long, mats As Object, mat As Object
Static regec As Object, domDoc As Object
lStart = InStr(1, stResponse, "id=""" & groupName & "_Group""")
lEnd = InStr(lStart, stResponse, "</ul>")

If regec Is Nothing Then
    Set regec = CreateObject("VBScript.RegExp")
    regec.Pattern = "onclick\=\""selectTab\(([^\)]+)[\s\S]+?(<p>[\s\S]+?</p>)[\s\S]+?(value\=\""([\s\S]+?))?</li>"
    regec.IgnoreCase = True
    regec.Global = True
    Set domDoc = CreateObject("Msxml2.DOMDocument")
End If

Set mats = regec.Execute(Mid(stResponse, lStart, lEnd - lStart + 5))
For Each mat In mats
    curRow = curRow + 1
    arr(curRow, 1) = groupName
    domDoc.LoadXML mat.submatches(1)
    arr(curRow, 2) = domDoc.Text
    arr(curRow, 3) = mat.submatches(0)
    If Len(mat.submatches(3)) > 0 Then
        arr(curRow, 4) = Left(mat.submatches(3), InStr(1, mat.submatches(3), """") - 1)
    End If
Next
End Sub


Chào bạn AutoReply!
Cảm ơn các code bạn viết. Mình sử dụng rất hay. Bạn có thể tách ra 3 sheets khác nhau HOSE, HNX, UPCOM trong file VCBS ko ah??? Vì mình thấy code của trang VCBS chạy nhanh hơn code FPTS( code FPTS trong giờ giao dịch khi chạy bị chậm rồi hiện lỗi "Timeout Error"
 
Lần chỉnh sửa cuối:
Sau khi tải về dùng được 1 thời gian thì xuất hiện lỗi như hình đính kèm, các bác cho em xin giải pháp với ạ!
Em dùng code bên file fpt.xlsb ạ!
 

File đính kèm

  • 2018-04-18_8-59-42.png
    2018-04-18_8-59-42.png
    51.3 KB · Đọc: 159
  • 2018-04-18_8-59-31.png
    2018-04-18_8-59-31.png
    6.1 KB · Đọc: 166
Trang vcbs

Mã:
Public Sub hello(ByVal selectedStocks As String, ByVal criteriaId As String, ByVal pthMktId As String)
Dim str As String, payload As String, arr
'template Payload:{"selectedStocks":"AAM,ABT","criteriaId":"-11","marketId":0,"lastSeq":0,"isReqTL":false,"isReqMK":false,"tlSymbol":"","pthMktId":""}
payload = "{""selectedStocks"":""" & selectedStocks & """,""criteriaId"":""" & criteriaId & """,""marketId"":0,""lastSeq"":0," & _
"""isReqTL"":false,""isReqMK"":false,""tlSymbol"":"""",""pthMktId"":""" & pthMktId & """}"
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "POST", "http://quotes.vcbs.com.vn/PriceBoard/Acc/amw", False
    .setRequestHeader "Content-Type", "application/json"
    .send (payload)
    str = .ResponseText
End With
If Len(pthMktId) = 0 Then
    arr = tachBangGia(str)
Else
    arr = tachGDTT(str)
End If
Sheet1.Range("A5").Resize(UBound(arr) + 1000, UBound(arr, 2) + 50).ClearContents
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

Private Function tachBangGia(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, arr, dArr, dicColName As Object, r As Long
Dim rowData, cellData, c As Long, colIndex As Long
Dim regec As Object, mats As Object, mat As Object
Set dicColName = CreateObject("Scripting.Dictionary")
dicColName.CompareMode = vbTextCompare
arr = Array("SB", "CL", "FL", "RE", "B3", "V3", "B2", "V2", "B1", "V1", "CH", "CP", "CV", "S1", _
"U1", "S2", "U2", "S3", "U3", "TT", "OP", "HI", "LO", "FB", "FS", "FR")
For r = 0 To UBound(arr) Step 1
    dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachBangGia = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """f"":["))
lEnd = InStr(lStart, stResponse, "],")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 1), "\""", "")
arr = Split(stResponse, "Id:")

Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "[A-Z][A-Z0-9]\:[^,]*(,\d+)*"
'[A-Z][A-Z0-9]\:.*?(?=,[A-Z][A-Z0-9]\:)
regec.Global = True

For r = LBound(arr) + 1 To UBound(arr) Step 1
    Set mats = regec.Execute(arr(r))
    For Each mat In mats
        cellData = Split(mat, ":")
        If dicColName.exists(cellData(0)) Then
            colIndex = dicColName(cellData(0))
            dArr(r, colIndex) = IIf(CStr(cellData(1)) = "null", "", cellData(1))
        End If
    Next
Next
tachBangGia = dArr
End Function

Private Function tachGDTT(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, dicColName As Object, arr, dArr, r As Long
Dim colIndex As Long, rowData, colName As String, cellData, c As Long

Set dicColName = CreateObject("Scripting.Dictionary")
arr = Array("Symbol", "Price", "MatchVol", "fake", "Time")
For r = 0 To UBound(arr) Step 1
    dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachGDTT = dArr

lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """pm"":["))
lEnd = InStr(lStart, stResponse, "}]")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 2), """", "")
arr = Split(stResponse, "{Id:")

For r = LBound(arr) + 1 To UBound(arr) Step 1
    rowData = Split(arr(r), ",")
    For c = LBound(rowData) + 1 To UBound(rowData) Step 1
        lStart = InStr(1, rowData(c), ":")
        If lStart > 0 Then
            cellData = Mid(rowData(c), lStart + 1)
            colName = Left(rowData(c), lStart - 1)
            If dicColName.exists(colName) Then
                colIndex = dicColName(colName)
                If colIndex = 2 Then
                    dArr(r, colIndex) = cellData / 1000
                    dArr(r, 4) = "=RC[-2] * RC[-1]"
                Else
                    dArr(r, colIndex) = cellData
                End If
            End If
        End If
    Next
Next
tachGDTT = dArr
End Function

Public Function createVcbsList()
Dim arr(1 To 50, 1 To 4), curRow As Long, str As String
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "GET", "http://quotes.vcbs.com.vn/PriceBoard", False
    .send
    str = .ResponseText
End With

tachGroup str, arr, "HOSE", curRow
tachGroup str, arr, "HNX", curRow
tachGroup str, arr, "UPCOM", curRow
createVcbsList = arr
End Function

Private Sub tachGroup(ByVal stResponse As String, ByRef arr, groupName As String, ByRef curRow As Long)
Dim lStart As Long, lEnd As Long, mats As Object, mat As Object
Static regec As Object, domDoc As Object
lStart = InStr(1, stResponse, "id=""" & groupName & "_Group""")
lEnd = InStr(lStart, stResponse, "</ul>")

If regec Is Nothing Then
    Set regec = CreateObject("VBScript.RegExp")
    regec.Pattern = "onclick\=\""selectTab\(([^\)]+)[\s\S]+?(<p>[\s\S]+?</p>)[\s\S]+?(value\=\""([\s\S]+?))?</li>"
    regec.IgnoreCase = True
    regec.Global = True
    Set domDoc = CreateObject("Msxml2.DOMDocument")
End If

Set mats = regec.Execute(Mid(stResponse, lStart, lEnd - lStart + 5))
For Each mat In mats
    curRow = curRow + 1
    arr(curRow, 1) = groupName
    domDoc.LoadXML mat.submatches(1)
    arr(curRow, 2) = domDoc.Text
    arr(curRow, 3) = mat.submatches(0)
    If Len(mat.submatches(3)) > 0 Then
        arr(curRow, 4) = Left(mat.submatches(3), InStr(1, mat.submatches(3), """") - 1)
    End If
Next
End Sub
Mình muốn thêm cái auto refresh thì làm thế nào nhỉ bạn :D
 
ồ thật vậy sao bạn ? Nhưng thôi mình không dám phản đối bạn đâu. Khi có quá ít thời gian thì đành phải công nhận như vậy, khỏe hơn. --=0--=0
Chào bạn AutoReply, bạn giúp mình đoạn code (chèn vào file của bạn) mà lấy được dữ liệu của chỉ số nữa không ạ? Chỉ số Vnindex, VN30,... Cám ơn bạn nhiều!!!
 


Dùng bảng của bác nó bị lỗi này: The operation timed out, bác có cách nào xử lý giúp e ko?

Trong giờ giao dịch Real Time nhẩy giá liên tục là bị, hết giờ bảng giá đứng im thì nó lại chẳng bị lỗi này nữa.... khổ ghê
 

File đính kèm

  • Error dowload bang gia.jpg
    Error dowload bang gia.jpg
    808 KB · Đọc: 121
Lần chỉnh sửa cuối:
Chào mọi người, hôm qua sau phiên giao dịch mình down về thì còn xài được nhưng trong phiên giao dịch sáng nay thì bị lỗi debug như sau. có cách nào để thay đổi sang website khác như https://trade-hn.vndirect.com.vn/chung-khoan/hose được ko ạ
 

File đính kèm

  • Capture.JPG
    Capture.JPG
    114.5 KB · Đọc: 94
các sư phụ cho e hỏi có tài liệu, giáo trình nào hướng dẫn sử dụng chi tiết món "CreateObject("MSXML2.ServerXMLHTTP")" này không ạ. trước e có tìm trong diễn đàn mình bài viết có món Dictionary, nhưng món CreateObject("MSXML2.ServerXMLHTTP không có trong diễn đàn mình ạ.nên mạo muội nhờ các sư phụ chỉ lối ^^^^
e cảm ơn!
 
Lần chỉnh sửa cuối:
có sư phụ nào có tài liệu không ạ. cho e xin với ><<...,
 
chào mọi người.
mọi người có biết lấy bảng giá chứng khoán theo nghành trực tuyến không giúp minh với

xin cam on moi nguoi ạ
 
Có cách nào lấy giá chứng khoán vào File ACCESS không bạn ?
 
dowload về máy xong báo lỗi timeout ko dùng đc
mong giúp đỡ
 
bạn AUTOREPLY ơi có thể chọn theo ngày tháng khác nhau được không, mình xin cám ơn !
 
xin chào anh chị,
em đã đọc các bình luận và giúp đỡ của mn, nhưng e vẫn ko hiểu làm thế nào để tải dữ liệu trong bảng trên link này ạ https://finance.yahoo.com/quote/^GSPC/history?p=^GSPC
anh chị nào có code xin giúp em với ạ :))
Trên Excel đời mới gần đây (2013, 2016, 2019, 365...) Bạn chỉ cần vào Tab Data -> From Web xong nhập địa chỉ trên vào rồi xử lý vài bước đơn giản rồi nó ra cái bảng bạn cần nhé.
 
Hi anh Auto Refresh, file này của anh có thẻ thêm 1 sheet bảng giá phải sinh và 1 sheet các chỉ số VNindex, Vn30, HNXindex, HNX30 không ạ. Nếu được phiền anh sửa giúp em nhé.

Em hôm nay mới tìm được topic này, mặc dù đúng vào phiên cuối tuần nên chưa thử chạy real time được nhưng em thâý file này rất hữu ích ạ.

Tks anh và mọi người nhé!
Bài đã được tự động gộp:

Hi anh Auto Refresh, file này của anh có thẻ thêm 1 sheet bảng giá phải sinh và 1 sheet các chỉ số VNindex, Vn30, HNXindex, HNX30 không ạ. Nếu được phiền anh sửa giúp em nhé.

Em hôm nay mới tìm được topic này, mặc dù đúng vào phiên cuối tuần nên chưa thử chạy real time được nhưng em thâý file này rất hữu ích ạ.

Tks anh và mọi người nhé!
 

File đính kèm

  • fpt (1).xlsb
    155.4 KB · Đọc: 168
Web KT
Back
Top Bottom