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

Liên hệ QC
Như post ạ, bạn nào có thể giúp mình lấy dữ liệu từ trang web https://trade-hn.vndirect.com.vn/chung-khoan/phai-sinh về excel được không. 2 trang FPT và VCBS không có nên mình cũng có tìm hiểu thêm mà chịu rồi :D
Bạn thử code này:
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp  As Object, url As String, arr, darr, npos, npos2, result
Dim i As Long, j As Long
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
url = "https://price-cmc-03.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 39, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
    Do While xmlHttp.readystate <> 4 'Or xmlHttp.Status <> 200
        DoEvents
    Loop
    arr = Split(.responsetext, ",")
End With
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2)))
Next i
For i = 1 To UBound(result)
    For j = 0 To UBound(npos2)
        result(i, npos2(j)) = result(i, npos2(j)) * 10
    Next j
Next i
[a3].Resize(UBound(result), UBound(result, 2)) = result
Set xmlHttp = Nothing: Erase arr: Erase darr: Erase result
Call design
Application.OnTime Now() + TimeValue("00:00:30"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a3:Y" & [D10000].End(xlUp).Row)
With Range("a3").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a1:y2].Font.Bold = True: [a1:y2].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c3:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a3:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d3:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e3:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f3:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
    Next j
Next i
Application.ScreenUpdating = True
End Sub
30s cập nhập 1 lần!!
 

File đính kèm

  • gpricestock.xlsb
    25.2 KB · Đọc: 120
Upvote 0
Bạn thử code này:
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp  As Object, url As String, arr, darr, npos, npos2, result
Dim i As Long, j As Long
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
url = "https://price-cmc-03.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 39, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
    Do While xmlHttp.readystate <> 4 'Or xmlHttp.Status <> 200
        DoEvents
    Loop
    arr = Split(.responsetext, ",")
End With
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2)))
Next i
For i = 1 To UBound(result)
    For j = 0 To UBound(npos2)
        result(i, npos2(j)) = result(i, npos2(j)) * 10
    Next j
Next i
[a3].Resize(UBound(result), UBound(result, 2)) = result
Set xmlHttp = Nothing: Erase arr: Erase darr: Erase result
Call design
Application.OnTime Now() + TimeValue("00:00:30"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a3:Y" & [D10000].End(xlUp).Row)
With Range("a3").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a1:y2].Font.Bold = True: [a1:y2].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c3:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a3:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d3:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e3:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f3:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
    Next j
Next i
Application.ScreenUpdating = True
End Sub
30s cập nhập 1 lần!!
Thanks bạn :D. H mình muốn thêm tên chứng khoán vào thì như nào nhỉ :D. Mình đã thử thêm VN30F1806, VN30F1807 vào nối tiếp sau VNM mà không ăn thua :D
 
Upvote 0
Bạn thử code này:
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp  As Object, url As String, arr, darr, npos, npos2, result
Dim i As Long, j As Long
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
url = "https://price-cmc-03.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 39, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
    Do While xmlHttp.readystate <> 4 'Or xmlHttp.Status <> 200
        DoEvents
    Loop
    arr = Split(.responsetext, ",")
End With
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2)))
Next i
For i = 1 To UBound(result)
    For j = 0 To UBound(npos2)
        result(i, npos2(j)) = result(i, npos2(j)) * 10
    Next j
Next i
[a3].Resize(UBound(result), UBound(result, 2)) = result
Set xmlHttp = Nothing: Erase arr: Erase darr: Erase result
Call design
Application.OnTime Now() + TimeValue("00:00:30"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a3:Y" & [D10000].End(xlUp).Row)
With Range("a3").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a1:y2].Font.Bold = True: [a1:y2].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c3:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a3:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d3:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e3:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f3:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
    Next j
Next i
Application.ScreenUpdating = True
End Sub
30s cập nhập 1 lần!!
Các mã thông thường như AAA, ACB mình thêm vào chạy bt nhưng các mã phái sinh như VN30F1806 thêm vào chạy không ra :D
 
Upvote 0
Mình hỏi chút, hôm chủ nhật mình mở lên ok nhưng nay lại báo lỗi là sao nhỉ :D
Web này nó lấy dữ liệu từ nhiều nguồn, bạn chạy code này :
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp1  As Object, url As String, arr, darr, npos, npos2, resul
Dim i As Long, j As Long
Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1") 'MSXML2.XMLHTTP
On Error Resume Next
Select Case [c2]
    Case "HNX"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:02"
    Case "HOUSE"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:10"
    Case "VN30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
    Case "HNX30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:ACB,BCC,BVS,CEO,DBC,DCS,DGC,HHG,HUT,IDV,LAS,LHC,MAS,NDN,NTP,PGS,PLC,PVC,PVI,PVS,S55,S99,SHB,SHS,TV2,VC3,VCG,VCS,VNR,VTV"
    Case "UPCOM"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:03"
    Case "PHAI SINH"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/derivative/snapshot/q=floorCode:DER01"
End Select
If [c2] Like "HNX*" Then
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
ElseIf [c2] = "PHAI SINH" Then
    npos = Array(24, 46, 14, 3, 12, 22, 50, 37, 7, 10, 6, 9, 5, 8, 27, 28, 31, 34, 32, 35, 33, 36, 38, 23, 26, 11, 42)
Else
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
End If
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
'    Do While xmlHttp.Status <> 200 'xmlHttp.readystate <> 4
'        DoEvents
'    Loop
    arr = Split(.responsetext, ",")
End With
[a7].Resize(UBound(arr), 1) = WorksheetFunction.Transpose(arr)
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = IIf(Len(result(i + 1, 1)) = 8, DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2))), "")
Next i
If [c2] <> "PHAI SINH" Then
    For i = 1 To UBound(result)
        For j = 0 To UBound(npos2)
            result(i, npos2(j)) = result(i, npos2(j)) * 10
        Next j
    Next i
End If
Range("a7:ac" & [D10000].End(xlUp).Row).Clear
If [c2] = "PHAI SINH" And [h5] <> "KL mo" Then
    [H1].EntireColumn.Insert: [h5] = "KL mo": [h5:h6].Merge
Else
    If [h5] = "KL mo" And [c2] <> "PHAI SINH" Then [H1].EntireColumn.Delete
End If
If [c2] = "PHAI SINH" And [w6] <> "Mo cua" Then
    [w1].EntireColumn.Insert: [w6] = "Mo cua"
Else
    If [v6] = "Mo cua" And [c2] <> "PHAI SINH" Then [v1].EntireColumn.Delete
End If
[a7].Resize(UBound(result), UBound(result, 2)) = result
Erase arr: Erase darr: Erase result: Erase xmlHttp: Erase npos: Erase npos2
Call design
Application.OnTime Now() + TimeValue("00:00:05"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a7:Y" & [D10000].End(xlUp).Row)
With Range("a7").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a5:y6].Font.Bold = True: [a5:y6].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c7:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a7:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d7:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e7:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f7:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
        If rng(i, 15) = 0 Then rng(i, 3).Font.ColorIndex = 6
    Next j
Next i
Application.ScreenUpdating = True
End Sub
Tôi đang để mặc định chạy 5s update 1 lần, muốn thay đổi bạn sửa chỗ TimeValue("00:00:05") là được.
 

File đính kèm

  • gpricestock2.xlsb
    37.4 KB · Đọc: 150
Upvote 0
Web này nó lấy dữ liệu từ nhiều nguồn, bạn chạy code này :
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp1  As Object, url As String, arr, darr, npos, npos2, resul
Dim i As Long, j As Long
Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1") 'MSXML2.XMLHTTP
On Error Resume Next
Select Case [c2]
    Case "HNX"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:02"
    Case "HOUSE"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:10"
    Case "VN30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
    Case "HNX30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:ACB,BCC,BVS,CEO,DBC,DCS,DGC,HHG,HUT,IDV,LAS,LHC,MAS,NDN,NTP,PGS,PLC,PVC,PVI,PVS,S55,S99,SHB,SHS,TV2,VC3,VCG,VCS,VNR,VTV"
    Case "UPCOM"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:03"
    Case "PHAI SINH"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/derivative/snapshot/q=floorCode:DER01"
End Select
If [c2] Like "HNX*" Then
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
ElseIf [c2] = "PHAI SINH" Then
    npos = Array(24, 46, 14, 3, 12, 22, 50, 37, 7, 10, 6, 9, 5, 8, 27, 28, 31, 34, 32, 35, 33, 36, 38, 23, 26, 11, 42)
Else
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
End If
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
'    Do While xmlHttp.Status <> 200 'xmlHttp.readystate <> 4
'        DoEvents
'    Loop
    arr = Split(.responsetext, ",")
End With
[a7].Resize(UBound(arr), 1) = WorksheetFunction.Transpose(arr)
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = IIf(Len(result(i + 1, 1)) = 8, DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2))), "")
Next i
If [c2] <> "PHAI SINH" Then
    For i = 1 To UBound(result)
        For j = 0 To UBound(npos2)
            result(i, npos2(j)) = result(i, npos2(j)) * 10
        Next j
    Next i
End If
Range("a7:ac" & [D10000].End(xlUp).Row).Clear
If [c2] = "PHAI SINH" And [h5] <> "KL mo" Then
    [H1].EntireColumn.Insert: [h5] = "KL mo": [h5:h6].Merge
Else
    If [h5] = "KL mo" And [c2] <> "PHAI SINH" Then [H1].EntireColumn.Delete
End If
If [c2] = "PHAI SINH" And [w6] <> "Mo cua" Then
    [w1].EntireColumn.Insert: [w6] = "Mo cua"
Else
    If [v6] = "Mo cua" And [c2] <> "PHAI SINH" Then [v1].EntireColumn.Delete
End If
[a7].Resize(UBound(result), UBound(result, 2)) = result
Erase arr: Erase darr: Erase result: Erase xmlHttp: Erase npos: Erase npos2
Call design
Application.OnTime Now() + TimeValue("00:00:05"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a7:Y" & [D10000].End(xlUp).Row)
With Range("a7").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a5:y6].Font.Bold = True: [a5:y6].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c7:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a7:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d7:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e7:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f7:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
        If rng(i, 15) = 0 Then rng(i, 3).Font.ColorIndex = 6
    Next j
Next i
Application.ScreenUpdating = True
End Sub
Tôi đang để mặc định chạy 5s update 1 lần, muốn thay đổi bạn sửa chỗ TimeValue("00:00:05") là được.
Thanks bạn nhé :D
 
Upvote 0
Nếu muốn lấy thêm thông tin cơ bản như tên công ty, mã sàn, EPS thì dùng cách này được không bạn.
 
Upvote 0
Bạn thử code này:
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp  As Object, url As String, arr, darr, npos, npos2, result
Dim i As Long, j As Long
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
url = "https://price-cmc-03.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 39, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
    Do While xmlHttp.readystate <> 4 'Or xmlHttp.Status <> 200
        DoEvents
    Loop
    arr = Split(.responsetext, ",")
End With
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2)))
Next i
For i = 1 To UBound(result)
    For j = 0 To UBound(npos2)
        result(i, npos2(j)) = result(i, npos2(j)) * 10
    Next j
Next i
[a3].Resize(UBound(result), UBound(result, 2)) = result
Set xmlHttp = Nothing: Erase arr: Erase darr: Erase result
Call design
Application.OnTime Now() + TimeValue("00:00:30"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a3:Y" & [D10000].End(xlUp).Row)
With Range("a3").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a1:y2].Font.Bold = True: [a1:y2].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c3:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a3:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d3:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e3:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f3:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
    Next j
Next i
Application.ScreenUpdating = True
End Sub
30s cập nhập 1 lần!!
Bài đã được tự động gộp:

excel_lv1.5 cho xin contact để trao đổi được ko?
 
Upvote 0
Web này nó lấy dữ liệu từ nhiều nguồn, bạn chạy code này :
PHP:
Public Sub getdataweb()
Application.ScreenUpdating = False
Dim xmlHttp1  As Object, url As String, arr, darr, npos, npos2, resul
Dim i As Long, j As Long
Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1") 'MSXML2.XMLHTTP
On Error Resume Next
Select Case [c2]
    Case "HNX"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:02"
    Case "HOUSE"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:10"
    Case "VN30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:BID,BMP,BVH,CII,CTD,CTG,DHG,DPM,FPT,GAS,GMD,HPG,HSG,KDC,MBB,MSN,MWG,NT2,NVL,PLX,REE,ROS,SAB,SBT,SSI,STB,VCB,VIC,VJC,VNM"
    Case "HNX30"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=codes:ACB,BCC,BVS,CEO,DBC,DCS,DGC,HHG,HUT,IDV,LAS,LHC,MAS,NDN,NTP,PGS,PLC,PVC,PVI,PVS,S55,S99,SHB,SHS,TV2,VC3,VCG,VCS,VNR,VTV"
    Case "UPCOM"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:03"
    Case "PHAI SINH"
        url = "https://price-fpt-01.vndirect.com.vn/priceservice/derivative/snapshot/q=floorCode:DER01"
End Select
If [c2] Like "HNX*" Then
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
ElseIf [c2] = "PHAI SINH" Then
    npos = Array(24, 46, 14, 3, 12, 22, 50, 37, 7, 10, 6, 9, 5, 8, 27, 28, 31, 34, 32, 35, 33, 36, 38, 23, 26, 11, 42)
Else
    npos = Array(1, 2, 3, 8, 15, 16, 36, 27, 28, 25, 26, 23, 24, 19, 20, 29, 30, 31, 32, 33, 34, 13, 14, 37, 38)
End If
npos2 = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
With xmlHttp
    .Open "GET", url, False
    .send
'    Do While xmlHttp.Status <> 200 'xmlHttp.readystate <> 4
'        DoEvents
'    Loop
    arr = Split(.responsetext, ",")
End With
[a7].Resize(UBound(arr), 1) = WorksheetFunction.Transpose(arr)
ReDim result(1 To UBound(arr) + 1, 1 To UBound(npos) + 1)
For i = 0 To UBound(arr)
    darr = Split(arr(i), "|")
    For j = 0 To UBound(npos)
        result(i + 1, j + 1) = darr(npos(j))
    Next j
    result(i + 1, 1) = IIf(Len(result(i + 1, 1)) = 8, DateSerial(Val(Left(result(i + 1, 1), 4)), Val(Mid(result(i + 1, 1), 5, 2)), Val(Mid(result(i + 1, 1), 7, 2))), "")
Next i
If [c2] <> "PHAI SINH" Then
    For i = 1 To UBound(result)
        For j = 0 To UBound(npos2)
            result(i, npos2(j)) = result(i, npos2(j)) * 10
        Next j
    Next i
End If
Range("a7:ac" & [D10000].End(xlUp).Row).Clear
If [c2] = "PHAI SINH" And [h5] <> "KL mo" Then
    [H1].EntireColumn.Insert: [h5] = "KL mo": [h5:h6].Merge
Else
    If [h5] = "KL mo" And [c2] <> "PHAI SINH" Then [H1].EntireColumn.Delete
End If
If [c2] = "PHAI SINH" And [w6] <> "Mo cua" Then
    [w1].EntireColumn.Insert: [w6] = "Mo cua"
Else
    If [v6] = "Mo cua" And [c2] <> "PHAI SINH" Then [v1].EntireColumn.Delete
End If
[a7].Resize(UBound(result), UBound(result, 2)) = result
Erase arr: Erase darr: Erase result: Erase xmlHttp: Erase npos: Erase npos2
Call design
Application.OnTime Now() + TimeValue("00:00:05"), "getdataweb"
Application.ScreenUpdating = True
End Sub
Sub design()
Application.ScreenUpdating = False
Dim rng As Range, rng1 As Range, arr, npos
arr = Array(8, 10, 12, 14, 16, 18, 20, 22, 23)
npos = Array(7, 9, 11, 13, 15, 17, 19, 21, 24, 25)
Set rng = Range("a7:Y" & [D10000].End(xlUp).Row)
With Range("a7").CurrentRegion
    .Font.Name = "Cambria"
    .Font.ColorIndex = 4
    .Interior.ColorIndex = 1
End With
[a5:y6].Font.Bold = True: [a5:y6].Font.ColorIndex = 2
'Range("d3:Y" & [D10000].End(xlUp).Row).NumberFormat = "#,###.00"
Range("c7:c" & [D10000].End(xlUp).Row).Font.Bold = True
Range("a7:Y" & [D10000].End(xlUp).Row).EntireColumn.AutoFit
Range("d7:d" & [D10000].End(xlUp).Row).Font.ColorIndex = 6
Range("e7:e" & [D10000].End(xlUp).Row).Font.ColorIndex = 7
Range("f7:f" & [D10000].End(xlUp).Row).Font.ColorIndex = 8
For i = 1 To rng.Rows.Count
    For j = 0 To UBound(arr)
        Select Case rng(i, arr(j))
            Case Is = rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 6
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 6
            Case Is = rng(i, 5)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 7
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 7
            Case Is = rng(i, 6)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 8
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 8
            Case Is < rng(i, 4)
                rng(i, arr(j)).Resize(1, IIf(arr(j) > 20, 1, 2)).Font.ColorIndex = 3
                If arr(j) = 14 Then rng(i, 3).Font.ColorIndex = 3
        End Select
        If rng(i, 15) = 0 Then rng(i, 3).Font.ColorIndex = 6
    Next j
Next i
Application.ScreenUpdating = True
End Sub
Tôi đang để mặc định chạy 5s update 1 lần, muốn thay đổi bạn sửa chỗ TimeValue("00:00:05") là được.
Cho mình hỏi chút là file này của bạn cột đầu tiên không hiện lên ngày , ở bảng giá phái sinh thì có hiện số nhưng lại không phải định dạng ngày/tháng/năm như bình thường , bạn có thể sửa lại cho hiện đúng được không ?

Nếu mình muốn tải dữ liệu từ bảng giá chứng khoán về 1 FILE excel chỉ với định dạng ngắn gọn là như dưới thì làm thế nào bạn ? VỚI MỖI DÒNG CHỈ CHO VÀO 1 Ô TRONG EXCEL thôi
<Ticker>,<DTYYYYMMDD>,<Open>,<High>,<Low>,<Close>,<Volume>
VN30F1M,20180913,947.00,955.00,952.00,953.30,9
VN30F1M,20180912,952.00,958.50,947.00,947.00,89
VN30F1M,20180911,939.00,952.00,935.70,952.00,71
 
Upvote 0
Bác excel_lv1.5 cho em hỏi cái phần .responsetext mà lấy từ trên web về sau đó được xử lý mảng để thành bảng giá, cái đó minh tìm ở phần nào trên web vậy bác. Kể cả các link như "https://price-fpt-01.vndirect.com.vn/priceservice/secinfo/snapshot/q=floorCode:10" bác tìm ở đâu ạ? Bác chỉ giúp em, em đang mò mẫm tìm hiểu về lấy dữ liệu trên web về excel bằng CreateObject("msxml2.xmlhttp").
 
Upvote 0
Web KT
Back
Top Bottom