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