save vba process data time

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??
Attachment 31470

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

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.

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  ' 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%2Cmean5volume%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

---

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

Code:

---

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

Code:

---

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

Code:

---

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.

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.

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??

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%2Cmean5volume%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

---

Attachment 31475Attachment 31476

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




this is my renew code:

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%2Cmean5volume%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

---