save vba process data time

[xyz987]

Hi Sirs
I get stock price history from "https://histock.tw/stock/chip/chartdata.aspx?no=1101&days=5&m=dailyk" , if the red word small, data is less, but big than process time will add very much. i try to use json vba process, but fail. can suggest to save the process time to this??
31470

[Aussiebear]

@xyz987, Please dont post images of code. We simply cannot read them to understand what you are chasing. Post the code instead please.

[xyz987]

sorry, i had attach file at end, image only help me to explame. change the no then data will add much cause time will long.

[xyz987]

Sub Hi_stock()
'Dim date_1 As Date
'date_1 = Date
'year_now = Year(date_1)
'month_now = Month(date_1)
'day_now = Day(date_1)
request_day = year_input_1 * 365
'start_year = year_now - year_input_1
'start_date_1 = start_year & "/" & month_now & "/" & day_now ' Perpetual Calendar Diplay
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) 'Unix 十 digit display
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) & "000" 'Unix + three digit display
'end_date_1 = year_now & "/" & month_now & "/" & day_now 'Perpetual Calendar Display
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) 'Unix 十digit display
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) & "000" 'Unix 十three digit display
'Hi investment historical stock price download
'url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=" & stock_no_1 & "&days=" & request_day & _
"&m=dailyk%2Cclose%2Cvolume%2Cmean5%2Cmean10%2Cmean20%2Cmean60%2Cmean120%2Cme an5volume%2Cmean20volume" & _
"%2Ck9%2Cd9%2Crsi6%2Crsi12%2Cdif%2Cmacd%2Cosc&fbclid=IwAR0w4tNJGIm8iSRsh7Zj_DBWESNSJ8DLJurdLZZR3--7vAkh5Xd7rPpT_bw"
Dim myXML As Object
Dim url_1 As String
Dim response As String
Dim json As Object
Dim data As Object
Dim ostream As Object
Set myXML = CreateObject("MSXML2.XMLHTTP")
url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=1101&days=5&m=dailyk"
With myXML
.Open "GET", url_1, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/123.0.0.0 Safari/537.36"
.send
response = myXML.responseText
'Debug.Print response
'Set json = JsonConverter.ParseJson(response)
'Set data = json("DailyK")
'Debug.Print stock
'If Asc(year_input_1) > 50 Then
'Application.Wait Now + TimeValue("00:00:20")
'End If
If myXML.Status = 200 Then
Set ostream = CreateObject("ADODB.Stream")
ostream.Open
ostream.Type = 1
ostream.write myXML.responseBody
ostream.savetofile "C:\stock\data\1101.csv", 2
ostream.Close
Else
'nothing
'no_stock (work_book)
End If
End With
'Stock Price Data display
Workbooks.Open Filename:="C:\stock\data\1101.csv"
Windows("1101.csv").Activate
a = 1
Do Until Cells(1, a) = ""
a = a + 1
Loop
'Special Characters & non stock price data removal
remove_list = "[]{}()"""""
For a1 = 1 To a - 1
If a1 = 1 Then
For i = 1 To Len(Cells(1, a1))
If Asc(Mid(Cells(1, a1), i, 1)) >= 48 And Asc(Mid(Cells(1, a1), i, 1)) <= 57 Then
'nothing
On Error Resume Next
Else
If Asc(Mid(Cells(1, a1), i, 1)) = 46 Then
'nothing
Else
Cells(1, a1) = Replace$(Cells(1, a1), Mid$(Cells(1, a1), i, 1), "")
i = 1
End If
End If
Next i
Cells(1, 1) = Replace$(Cells(1, 1), Mid$(Cells(1, 1), 1, 1), "")
Else
For i = 1 To Len(remove_list)
Cells(1, a1) = Replace$(Cells(1, a1), Mid$(remove_list, i, 1), "")
Next
If Asc(Mid(Cells(1, a1), 1, 1)) >= 48 And Asc(Mid(Cells(1, a1), 1, 1)) <= 57 Then
'nothing
Else
Range(Cells(1, a1), Cells(1, a - 1)).Clear
Exit For
End If
End If
Next a1
On Error GoTo error_stop
Windows("1101.csv").Save
a = 1
Do Until Cells(1, a) = ""
a = a + 1
Loop
If Len(Dir("C:\stock\analysis" & stock_no_1 & ".xlsx")) > 0 Then Kill "C:\stock\analysis" & stock_no_1 & ".xlsx"
''SetAttr "C:\stock\analysis\*.*", vbNormal ' Troubleshoot read only file issues
Workbooks.Add
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\stock\analysis\1101.xlsx"
Application.DisplayAlerts = True
Windows("1101.xlsx").Activate
ActiveSheet.Name = "Price"
Cells(1, 1) = "Date"
Cells(1, 2) = "Open"
Cells(1, 3) = "Highest"
Cells(1, 4) = "Lowest"
Cells(1, 5) = "Close"
'Pause four things that tend to slow down Excel 功能
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
b = 2
For a = 1 To a - 1 Step 5
Workbooks("1101.csv").Sheets("1101").Activate
Range(Cells(1, a), Cells(1, a + 4)).Select
Selection.Copy
Workbooks("1101.xlsx").Sheets("Price").Activate
Cells(b, 1).Select
ActiveSheet.Paste
b = b + 1
Next a
Workbooks("1101.xlsx").Sheets("Price").Activate
a = 1
Do Until Cells(a, 1) = ""
a = a + 1
Loop
For a = 2 To a - 1
Cells(a, 1) = (Cells(a, 1) / 1000 + 8 * 3600) / 86400 + 70 * 365 + 19
Cells(a, 1) = Format(Cells(a, 1), "yyyy-mm-dd")
'Pause four things that tend to slow down Excel function
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Rows("1:1").Select
ActiveWindow.FreezePanes = True
Workbooks("1101.csv").Activate
Application.DisplayAlerts = False
Windows("1101.csv").Close (vb = Yes)
Application.DisplayAlerts = True
'dividend_process work_book, data_type, year_input_1, stock_no_1, data_row
Exit Sub
error_stop:
For file_check = 1 To Workbooks.Count
If Workbooks(file_check).Name = "*.csv" Then
Windows("*.csv").Activate
Application.DisplayAlerts = False
Windows("*.csv").Close (vb = no)
Application.DisplayAlerts = True
End If
Next file_check
'For file_check = 1 To Workbooks.Count
'If Workbooks(file_check).Name = "1101.xlsx" Then
'Windows("1101.xlsx").Activate
'Application.DisplayAlerts = False
'Windows("1101.xlsx").Close (vb = no)
'Application.DisplayAlerts = True
'Exit For
'End If
'Next file_check
Resume Next
End Sub

[Aussiebear]

Just a couple of quick things that I noticed within your code, and again I guess it comes down to coding style.

Firstly the use of .select. Where ever possible try not to use .Select. For example


For a = 1 To a - 1 Step 5
Workbooks("1101.csv").Sheets("1101").Activate
Range(Cells(1, a), Cells(1, a + 4)).Select
Selection.Copy
Workbooks("1101.xlsx").Sheets("Price").Activate
Cells(b, 1).Select
ActiveSheet.Paste
b = b + 1
Next a


Could be written as


For a = 1 To a - 1 Step 5
Workbooks("1101.csv").Sheets("1101").Activate
Range(Cells(1, a), Cells(1, a + 4)).Copy
Workbooks("1101.xlsx").Sheets("Price").Activate
Cells(b, 1).Paste
b = b + 1
Next a


Next issue is the logic behind an If test where you have written


For i = 1 To Len(Cells(1, a1))
If Asc(Mid(Cells(1, a1), i, 1)) >= 48 And Asc(Mid(Cells(1, a1), i, 1)) <= 57 Then
'nothing
On Error Resume Next
Else
If Asc(Mid(Cells(1, a1), i, 1)) = 46 Then
'nothing
Else
Cells(1, a1) = Replace$(Cells(1, a1), Mid$(Cells(1, a1), i, 1), "")
i = 1
End If
End If
Next i
Cells(1, 1) = Replace$(Cells(1, 1), Mid$(Cells(1, 1), 1, 1), "")
Else
For i = 1 To Len(remove_list)
Cells(1, a1) = Replace$(Cells(1, a1), Mid$(remove_list, i, 1), "")
Next
If Asc(Mid(Cells(1, a1), 1, 1)) >= 48 And Asc(Mid(Cells(1, a1), 1, 1)) <= 57 Then
'nothing
Else
Range(Cells(1, a1), Cells(1, a - 1)).Clear
Exit For
End If
End If


Where you are testing an If value is true, where true do nothing else do something else. I believe you should be simply testing the If value is false, do something otherwise end If.

Others may feel differently and I await their response to this post.

[p45cal]

Change the value in cell G1 of the attached, then right-click on the green table and choose Refresh.
Is this the kind of thing you're looking for?
Is it any faster?

I've only put this together quickly, it can be refined and made more flexible.

[xyz987]

Thanks sirs help, i try change it to json frame, the string looks like ok (I use other website to check),but when i use json parse, it not shows, is it something wrong??


Sub Hi_stock()
'Dim date_1 As Date
'date_1 = Date
'year_now = Year(date_1)
'month_now = Month(date_1)
'day_now = Day(date_1)
'request_day = year_input_1 * 365
'start_year = year_now - year_input_1
'start_date_1 = start_year & "/" & month_now & "/" & day_now '萬年曆顯示
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) 'Unix 十位數顯示
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) & "000" 'Unix 十三位數顯示
'end_date_1 = year_now & "/" & month_now & "/" & day_now '萬年曆顯示
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) 'Unix 十位數顯示
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) & "000" 'Unix 十三位數顯示
'Hi 投資 歷史股價下載
'url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=" & stock_no_1 & "&days=" & request_day & _
"&m=dailyk%2Cclose%2Cvolume%2Cmean5%2Cmean10%2Cmean20%2Cmean60%2Cmean120%2Cme an5volume%2Cmean20volume" & _
"%2Ck9%2Cd9%2Crsi6%2Crsi12%2Cdif%2Cmacd%2Cosc&fbclid=IwAR0w4tNJGIm8iSRsh7Zj_DBWESNSJ8DLJurdLZZR3--7vAkh5Xd7rPpT_bw"
Dim myXML As Object
Dim url_1 As String
Dim response As String
Dim newstr As String
Dim json As Object
a = 10
b = 2
Set myXML = CreateObject("MSXML2.XMLHTTP")
url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=1101&days=3&m=dailyk"
With myXML
.Open "GET", url_1, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/123.0.0.0 Safari/537.36"
.send
response = myXML.responseText
Debug.Print response
'TYPE 1
newstr = Replace(response, "{" & """" & "DailyK" & """" & ":" & """" & "[", "{" & """" & "1" & """" & ":", 1, 1) 'head
newstr = Replace(newstr, "]" & """", "", 1, 1) 'end
Debug.Print newstr
'TYPE 2
'newstr = Replace(response, """" & "[", "{" & """" & "1" & """" & ":", 1, 1) 'head
'newstr = Replace(newstr, "]" & """", "}", 1, 1) 'end
'Debug.Print newstr
For a_1 = 1 To a
newstr = Replace(newstr, "],[", "]," & """" & b & """" & ":[", 1, 1)
b = b + 1
Next a_1
Debug.Print newstr
Set json = JsonConverter.ParseJson(newstr)
Debug.Print json(1) 'TYPE 1
Debug.Print json("DailyK")(1) 'TYPE 2
'If myXML.Status = 200 Then
'Set ostream = CreateObject("ADODB.Stream")
'ostream.Open
'ostream.Type = 1
'ostream.write myXML.responseBody
'ostream.savetofile "C:\stock\data" & stock_no_1 & ".csv", 2
'ostream.Close
'Else
'no_stock (work_book)
'End If
End With
End Sub

3147531476

[xyz987]

Hi Sirs:
I already change it to json frame, and process time came compress very short, thanks for every one support.
31485 31486




this is my renew code:


Sub Hi_stock()
'Dim date_1 As Date
'date_1 = Date
'year_now = Year(date_1)
'month_now = Month(date_1)
'day_now = Day(date_1)
'request_day = year_input_1 * 365
'start_year = year_now - year_input_1
'start_date_1 = start_year & "/" & month_now & "/" & day_now '萬年曆顯示
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) 'Unix 十位數顯示
'start_date_2 = DateDiff("s", "1970-1-1 0:0:0", start_date_1) & "000" 'Unix 十三位數顯示
'end_date_1 = year_now & "/" & month_now & "/" & day_now '萬年曆顯示
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) 'Unix 十位數顯示
'end_date_2 = DateDiff("s", "1970-1-1 0:0:0", end_date_1) & "000" 'Unix 十三位數顯示
'Hi 投資 歷史股價下載
'url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=" & stock_no_1 & "&days=" & request_day & _
"&m=dailyk%2Cclose%2Cvolume%2Cmean5%2Cmean10%2Cmean20%2Cmean60%2Cmean120%2Cme an5volume%2Cmean20volume" & _
"%2Ck9%2Cd9%2Crsi6%2Crsi12%2Cdif%2Cmacd%2Cosc&fbclid=IwAR0w4tNJGIm8iSRsh7Zj_DBWESNSJ8DLJurdLZZR3--7vAkh5Xd7rPpT_bw"
Dim myXML As Object
Dim url_1 As String
Dim response As String
Dim newstr As String
Dim json As Object
'Dim data_1 As Object
Set myXML = CreateObject("MSXML2.XMLHTTP")
url_1 = "https://histock.tw/stock/chip/chartdata.aspx?no=1101&days=1095&m=dailyk"
With myXML
.Open "GET", url_1, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/123.0.0.0 Safari/537.36"
.send
response = myXML.responseText
'Debug.Print response
'TYPE 1
'newstr = Replace(response, "{" & """" & "DailyK" & """" & ":" & """" & "[", "{" & """" & "1" & """" & ":", 1, 1) 'head
'newstr = Replace(newstr, "]" & """", "", 1, 1) 'end
'Debug.Print newstr
'TYPE 2
'newstr = Replace(response, """" & "[", "{" & """" & "1" & """" & ":", 1, 1) 'head
'newstr = Replace(newstr, "]" & """", "}", 1, 1) 'end
'Debug.Print newstr
'For a_1 = 1 To a
'newstr = Replace(newstr, "],[", "]," & """" & b & """" & ":[", 1, 1) 'TYPE 1
'b = b + 1 'TYPE 1 & 2
'Next a_1
'TYPE 3
'newstr = Replace(response, """" & "[[", "[[" & """", 1, 1) 'head
'newstr = Replace(newstr, "]]" & """", """" & "]", 1, 1) 'end
'newstr = Replace(newstr, ",", """" & "," & """") 'TYPE 3
'newstr = Replace(newstr, "]" & """" & "," & """" & "[", """" & "]" & "," & "[" & """", 1, 1) 'TYPE 3
'newstr = Replace(newstr, "{", "[{", 1, 1) 'TYPE 3
'newstr = Replace(newstr, "}", "]}]", 1, 1) 'TYPE 3
'TYPE 4
newstr = Replace(response, "{" & """" & "DailyK" & """" & ":" & """" & "[", "", 1, 1) 'head
newstr = Replace(newstr, "]" & """" & "}", "", 1, 1) 'end
newstr = Replace(newstr, "[", "{" & """" & "time" & """" & ":")
newstr = Replace(newstr, "]", "}")
For a = 1 To 9999
For b = 1 To 5
If b = 1 Then newstr = Replace(newstr, ",", """" & "open" & """" & ":", 1, 1)
If b = 2 Then newstr = Replace(newstr, ",", """" & "high" & """" & ":", 1, 1)
If b = 3 Then newstr = Replace(newstr, ",", """" & "low" & """" & ":", 1, 1)
If b = 4 Then newstr = Replace(newstr, ",", """" & "close" & """" & ":", 1, 1)
If b = 5 Then newstr = Replace(newstr, ",", "test", 1, 1)
Next b
Next a
newstr = Replace(newstr, """" & "open", "," & """" & "open")
newstr = Replace(newstr, """" & "high", "," & """" & "high")
newstr = Replace(newstr, """" & "low", "," & """" & "low")
newstr = Replace(newstr, """" & "close", "," & """" & "close")
newstr = Replace(newstr, "test", ",")
newstr = "[" + newstr + "]"
'Debug.Print newstr
Set json = JsonConverter.ParseJson(newstr)
For a = 1 To 9999
On Error GoTo end_1
data_1 = json(a)("time")
open_1 = json(a)("open")
high_1 = json(a)("high")
low_1 = json(a)("low")
close_1 = json(a)("close")
'Debug.Print data_1, open_1, high_1, low_1, close_1
Workbooks("test1.xlsm").Sheets("Sheet2").Activate
'Columns("A:A").Select
'Selection.NumberFormatLocal = "0000000000000"
Cells(a, 1) = json(a)("time") / 86400000 + DateSerial(1970, 1, 1)
Cells(a, 2) = json(a)("open")
Cells(a, 3) = json(a)("high")
Cells(a, 4) = json(a)("low")
Cells(a, 5) = json(a)("close")
Columns("A:A").Select
Selection.NumberFormatLocal = "yyyy/m/d"
Next a
End With
end_1:
'nothing
Exit Sub
End Sub