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
Mong được các anh giành thời gian giúp đỡ :(
 
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
 

File đính kèm

  • vcbs.xlsb
    52.8 KB · Đọc: 968
ồ 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
í, hổng chịu đâu. :(:(
Bạn ở trên biểu là "nghĩ" như thế thôi.
Cô Rô bốt mà dỗi là bắt đền bạn ở trên. Hu hu.
 

File đính kèm

  • upload_2017-9-17_23-20-39.png
    upload_2017-9-17_23-20-39.png
    187.3 KB · Đọc: 241
  • upload_2017-9-17_23-21-35.png
    upload_2017-9-17_23-21-35.png
    132.8 KB · Đọc: 219
í, hổng chịu đâu. :(:(
Bạn ở trên biểu là "nghĩ" như thế thôi.
Cô Rô bốt mà dỗi là bắt đền bạn ở trên. Hu hu.

Tôi không biết gì hết, không hiểu gì hết. Giờ các bạn diễn đàn nói gì tôi cũng thấy đúng. Thế là nhẹ nhàng thanh thản. hi hi %#^#$%#^#$
 
Bạn @AutoReply mình hỏi xíu mình muốn lấy theo ngành với lại macro tự động cập nhật số mới của thị trường sau 3 phút hay 5 phút gì đó thì mình code mình nên viết ntn nhỉ? mình cũng không rành phần này lắm
Cảm ơn bạn nhiều
 
Em lần đầu tiên vào web e thấy bác @AutoReply siêu thật. E chưa bao giờ được học nhưng thấy các anh viết trên đây thật ngưỡng mộ các anh. Chúc các anh sức khoẻ và thành công.
 
cám ơn bác rất nhiều, em tìm cách link dữ liệu mãi mà không được.
 
bạn Autoreply ơi, chỉ giúp mình với. Mình ko thấy có nút bấm nào trên file cả, nút bấm đó ở đâu à bạn
 
Web KT
Back
Top Bottom