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

culibate · 5/7/19

Fpts chặn priceboard rồi, giờ phải có tk mới vào được

maichius · 29/7/19

tatylic đã viết:
Cảm ơn bác nhé, file này bác làm đấy ạ ?

bac cho huong dan su dung file. toi mo ra ko biet lam. lam sao dua bang gia chung khoan vao bangr cua bac duoc???

xuanvietinfo · 5/11/19

AutoReply đã viết:

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

Cái này bạn có thể cho mỗi bảng của ba sàn lúc lấy về cho vào 3 sheet khác nhau được k?

HeSanbi · 5/11/19

xuanvietinfo đã viết:
Cái này bạn có thể cho mỗi bảng của ba sàn lúc lấy về cho vào 3 sheet khác nhau được k?

Bạn có thể tham khảo file Bài viết bên này
Bảng giá trực tuyến

088958595 · 14/11/19

AutoReply đã viết:

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

Có thể lấy dữ liệu bảng giá phái sinh và chứng quyền không anh ơi

AutoReply · 14/11/19

088958595 đã viết:
Có thể lấy dữ liệu bảng giá phái sinh và chứng quyền không anh ơi

Mình không biết lấy bạn ơi. Bạn liên hệ bài #64 nhé.

joeofexcel · 18/5/20

AutoReply đã viết:
Mình không biết lấy bạn ơi. Bạn liên hệ bài #64 nhé.

Bác ơi, cháu tìm trên internet có mỗi file của bác là lấy được dữ liệu bảng giá, nhưng chỉ lấy được dữ liệu một sàn nhất định mỗi lần.
Hiện cháu mong muốn lấy bảng giá trực tuyến, toàn bộ giữ liệu của mỗi sàn (3 sàn - tất cả các mã) vào chung một sheet/hoặc mỗi sàn vào một sheet cũng được ạ. (Nếu có thể thêm được auto refresh theo thời gian đặt thì tốt cho cháu lắm ạ).
Nhờ Bác có thể chỉnh giúp cháu được không ạ.
Đây là file của bác đã làm trong chủ đề ạ.
Cháu cám ơn các bác nhiều ạ!

https://www.dropbox.com/s/te1ga2pam9infcm/vcbs%20-%20Copy.xlsb?dl=1

phananhkhoa · 15/7/20

Trên vcbs bị chặn rồi. Xin bác @AutoReply giúp với. Lỗi chắc ở khúc này. Đường link ko vào được nữa.

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

XIN LỖI LÀM PHIỀN BÁC. ĐÃ TRUY CẬP LẠI BÌNH THƯỜNG RỒI Ạ.

kid_kiss_kick · 31/12/20

AutoReply đã viết:

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

Bác ơi, trang bảng giá của VCBS mới thay đổi hôm nay (31/12/2020), giờ file này không update được nữa. Bác xem chỉnh sửa file giúp theo bảng giá mới của VCBS được không ạ. Cám ơn bác nhiều!

kid_kiss_kick · 26/1/21

kid_kiss_kick đã viết:
Bác ơi, trang bảng giá của VCBS mới thay đổi hôm nay (31/12/2020), giờ file này không update được nữa. Bác xem chỉnh sửa file giúp theo bảng giá mới của VCBS được không ạ. Cám ơn bác nhiều!

Nhờ bác @AutoReply giúp mình với ạ!

romatri · 31/1/21

AutoReply đã viết:
Mình không biết lấy bạn ơi. Bạn liên hệ bài #64 nhé.

NHờ bác update lại link của vcbs với ạ

HeSanbi · 31/1/21

@romatri, @kid_kiss_kick, @phananhkhoa, @joeofexcel

Các bác có thể tải file tham khảo từ Github ở link bài viết bên dưới

https://www.giaiphapexcel.com/diendan/threads/110725/

vithong · 1/3/21

AutoReply đã viết:

trong file có cái nút bấm , tùy chọn sàn mà lấy nhé

Mã:

Public Sub hello(ByVal region As String, ByVal targetTB As String)
Dim arr(1 To 2000, 1 To 25), r As Long, str As String
Dim mats, mapID, mat, dArr, ub As Long, col As Long
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "GET", "http://priceboard.fpts.com.vn/" & region & "/data.ashx?s=quote&l=" & targetTB, False
    .send
    str = .ResponseText
End With
mapID = Array(1, 2, 3, 4, -1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, _
        16, 17, 18, 19, -1, 20, 21, 22, 23, -1, 24, 25)
ub = UBound(mapID) + 1
With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\[""?(\d{1,2})""?,""?([^\]""]+)""?"
    dArr = Split(str, "}")
    For r = 0 To UBound(dArr)
        Set mats = .Execute(dArr(r))
        For Each mat In mats
            col = mat.submatches(0)
            If col < ub Then
                If mapID(col) > 0 Then
                    arr(r + 1, mapID(col)) = mat.submatches(1)
                End If
            End If
        Next
    Next
End With
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

làm ơn nói kỹ
tôi chưa va cái này bao giờ

Bài đã được tự động gộp: 1/3/21

có ai biết tải thì giúp với ạ

HeSanbi · 1/3/21

vithong

Bác có thể tham khảo thêm ứng dụng tại bài viết ở link bên dưới:

Lấy dữ liệu Tài chính và Bảng Giá Chứng Khoán từ Internet vào Excel siêu nhanh (Phần 2)

***ỨNG DỤNG SẼ SỚM CẬP NHẬT TRỞ LẠI*** --------------------------------------------------- Ứng dụng Lấy dữ liệu Chứng Khoán và Tài chính từ Website vào bảng tính Excel Phần 2 giúp cải thiện tốc độ lấy dữ liệu lên đáng kể nhờ sử dụng cơ chế Bất đồng bộ để tải dữ liệu. Phiên bản hiện tại sẽ giúp...

www.giaiphapexcel.com

vithong · 9/4/21

k-phong đã viết:
Tôi có bảng update giá chứng khoán trực tuyến = excel nhé.
Bạn cần thì View attachment 174682

tôi mở ra chạy báo lỗi bạn ơi

Love GPE · 1/6/21

AutoReply đã viết:

trong file có cái nút bấm , tùy chọn sàn mà lấy nhé

Mã:

Public Sub hello(ByVal region As String, ByVal targetTB As String)
Dim arr(1 To 2000, 1 To 25), r As Long, str As String
Dim mats, mapID, mat, dArr, ub As Long, col As Long
With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "GET", "http://priceboard.fpts.com.vn/" & region & "/data.ashx?s=quote&l=" & targetTB, False
    .send
    str = .ResponseText
End With
mapID = Array(1, 2, 3, 4, -1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, _
        16, 17, 18, 19, -1, 20, 21, 22, 23, -1, 24, 25)
ub = UBound(mapID) + 1
With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\[""?(\d{1,2})""?,""?([^\]""]+)""?"
    dArr = Split(str, "}")
    For r = 0 To UBound(dArr)
        Set mats = .Execute(dArr(r))
        For Each mat In mats
            col = mat.submatches(0)
            If col < ub Then
                If mapID(col) > 0 Then
                    arr(r + 1, mapID(col)) = mat.submatches(1)
                End If
            End If
        Next
    Next
End With
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

Em chào Chị AutoReply xinh đẹp!
Em có tải file ở bài #7 về chạy mà nó không chạy. Em gửi Chị đường link nguồn một số trang lấy bảng giá chứng khoán:
https://priceboard.vcbs.com.vn/Priceboard
https://iboard.ssi.com.vn/bang-gia-ssi/hose
https://liveboard.cafef.vn/?center=1
https://banggia.vndirect.com.vn/chung-khoan/danh-muc
Chị có thể sửa lại code, chỉ cần bấm 1 cái là code chạy full các mã của 2 sàn giao dịch: Hồ chí minh và Hà Nội. Rất mong Chị giúp đỡ. Cảm ơn Chị nhiều!

ravento · 3/6/21

AutoReply đã viết:

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

Bạn AutoReply ơi bạn có thể sửa lại code của bảng VCBS được không vì hiện nó bị lỗi không dùng được.
Cảm ơn bạn nhiều!

ravento · 3/6/21

ravento đã viết:
Bạn AutoReply ơi bạn có thể sửa lại code của bảng VCBS được không vì hiện nó bị lỗi không dùng được.
Cảm ơn bạn nhiều!

Mình đã đổi lại link của VCBS nhưng nó bị lỗi ở câu lệnh bị bôi vàng như sau:

Bạn có thể sửa giúp được không? Cảm ơn bạn nhiều!

ravento · 4/6/21

k-phong đã viết:
Tôi có bảng update giá chứng khoán trực tuyến = excel nhé.
Bạn cần thì View attachment 174682

Bảng của Bác, mình tải về bị lỗi Bác có sửa được không? Nếu sửa được gửi cho mình với.
Cảm ơn Bác nhiều!

Goldenct · 23/6/21

tren nay nhieu nguoi gioi qua, bai phuc bai phuc

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

Thành viên mới

Thành viên mới

Thành viên mới

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên mới

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

@romatri, @kid_kiss_kick, @phananhkhoa, @joeofexcel​

Thành viên mới

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

vithong​

Thành viên mới

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên mới

Đếm ngược thời gian

@romatri, @kid_kiss_kick, @phananhkhoa, @joeofexcel

vithong