返回列表 上一主題 發帖

[發問] 擷取每日成交資料

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2014-6-2 17:20 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-6-2 17:22 編輯

回復 1# chairmen100
使用單步執行沒又問題 但是 free run Excel 卻又 沒有回應

你的程式有在跑,但太多的迴圈所致,你誤以為沒有回應
修改一下試試看
  1. Sub 每日成交資料()
  2. Dim Y As String, m As String, D As String, tse_ymd As String, xlyear As String, tse_web As String
  3. Dim i As Integer, N As Integer, qyt As QueryTable, Dept_Row As Integer, MyStr As String, stkstr As String
  4. Dim Stock_date As Date, objrange As Range
  5. Dim URNG As Range, dic As Object, x As Integer, k As Variant, Msg As Boolean
  6.   '  Application.ScreenUpdating = False  '註解掉:看程式有在 Run 的
  7.     Application.DisplayStatusBar = True
  8.     If New確認工作表("TempG") = False Then Worksheets.Add(after:=Worksheets("每日成交資料")).Name = "TempG"
  9.     Sheets("每日成交資料").Select
  10.     'Stock_date = Sheets("每日成交資料").Range("I1")  '日期還要加一天
  11.     If Sheets("每日成交資料").Range("I1") = "" Then
  12.         Stock_date = CDate("2014/4/1")
  13.     Else
  14.         Stock_date = Sheets("每日成交資料").Range("I1") + 1 '日期還要加一天
  15.     End If
  16.     On Error Resume Next
  17.     Do While DateDiff("d", Stock_date, Now()) >= 0
  18.         While Weekday(Stock_date, 2) > 5 'finding work day
  19.             Stock_date = DateAdd("d", 1, Stock_date)
  20.         Wend
  21.         If DateDiff("d", Stock_date, #5/1/2014#) = 0 Then Stock_date = DateAdd("d", 1, Stock_date)
  22.         Y = Format(Year(Stock_date), "0000")
  23.         m = Format(Month(Stock_date), "00")
  24.         D = Format(Day(Stock_date), "00")
  25.         xlyear = CStr(CInt(Y) - 1911)
  26.         tse_ymd = xlyear & "/" & m & "/" & D
  27.         Set objrange = Sheets("每日成交資料").Range("I1:J1").EntireColumn 'shift two col to right
  28.         objrange.Insert (xlShiftToRight)
  29.         
  30.         Sheets("每日成交資料").Range("I1:J1") = Format(Stock_date, "yyyy/mm/dd")
  31.         For i = 1 To 2
  32.             Sheets("TempG").Cells.Clear
  33.             Sheets("TempG").Cells.ClearContents
  34.             Msg = False
  35.             Select Case i
  36.             Case 1
  37.                 tse_web = "http://www.twse.com.tw/ch/trading/exchange/MI_INDEX/genpage/Report" & Y & m & "/A112" & Y & m & D & "ALLBUT0999_1.php?select2=ALLBUT0999&chk_date=" & tse_ymd
  38.                 stkstr = " 上市股價........"
  39.                 Application.StatusBar = "擷取 " & tse_ymd & " " & stkstr
  40.                 With Sheets("TempG").QueryTables.Add(Connection:="URL;" & tse_web, Destination:=Sheets("TempG").Range("A1"))
  41.                     'If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"
  42.                     .WebFormatting = xlWebFormattingNone
  43.                     .WebSelectionType = xlSpecifiedTables
  44.                     .WebTables = "10"
  45.                     .Refresh 0
  46.                     If .ResultRange.Count = 2 Or Err <> 0 Then '"資料查詢失敗"
  47.                         Msg = True
  48.                         GoTo Next_Do
  49.                     End If
  50.                     .Delete
  51.                 End With
  52.             Case 2
  53.                 stkstr = " 上櫃股價........"
  54.                 Application.StatusBar = "擷取 " & tse_ymd & " " & stkstr
  55.                 tse_web = "http://www.gretai.org.tw/ch/stock/aftertrading/otc_quotes_no1430/stk_wn1430_print.php?d=" & tse_ymd & "&se=EW&s=0,asc,0"
  56.                 With Sheets("TempG").QueryTables.Add(Connection:="URL;" & tse_web, Destination:=Sheets("TempG").Range("A1"))
  57.                     .WebFormatting = xlWebFormattingNone
  58.                     .Refresh 0
  59.                     .Delete
  60.                 End With
  61.         End Select
  62.         Set dic = CreateObject("scripting.dictionary") '字典物件
  63.         For Each URNG In Sheets("TempG").UsedRange.Columns(1).Cells
  64.             If VBA.IsNumeric(URNG.Value) = True And Len(URNG.Value) = 4 Then
  65.                 dic(URNG & "," & URNG(1, 2)) = Array(URNG(1, IIf(i = 1, "C", "H")), URNG(1, IIf(i = 1, "I", "C")))
  66.                 ' Call 複製每日成交資料(URNG, "每日成交資料", Dept_Row, i)
  67.                 ' Dept_Row = Dept_Row + 1
  68.              End If
  69.         Next
  70.         'RUN 太多次 Sub 複製每日成交資料, 浪費時間
  71.         With Sheets("每日成交資料") '導入字典物件的key , item
  72.             x = 2
  73.             If [count(每日成交資料!a:a)] = 0 Then  '當資料是空白時
  74.                 For Each k In dic.keys
  75.                     .Cells(x, "a") = Split(k, ",")(0)
  76.                     .Cells(x, "b") = Split(k, ",")(1)
  77.                     .Cells(x, "i") = dic(k)(0)
  78.                     .Cells(x, "j") = dic(k)(1)
  79.                     x = x + 1
  80.                 Next
  81.             Else
  82.                 Do While .Cells(x, "a") <> ""
  83.                     k = .Cells(x, "a") & "," & .Cells(x, "b")
  84.                     If dic.exists(k) Then
  85.                         .Cells(x, "i") = dic(k)(0)
  86.                         .Cells(x, "j") = dic(k)(1)
  87.                         dic.Remove k  '移除字典物件的key
  88.                     End If
  89.                     x = x + 1
  90.                 Loop
  91.                 If dic.Count > 0 Then
  92.                     For Each k In dic.keys
  93.                         .Cells(x, "a") = Split(k, ",")(0)
  94.                         .Cells(x, "b") = Split(k, ",")(1)
  95.                         .Cells(x, "i") = dic(k)(0)
  96.                         .Cells(x, "j") = dic(k)(1)
  97.                         x = x + 1
  98.                     Next
  99.                 End If
  100.             End If
  101.         End With
  102.         '*********************
  103.     Next
  104. '============================================================================================================================================================================================
  105. Next_Do:
  106.     If Msg = True Then Sheets("每日成交資料").Range("I1:J1").EntireColumn.Delete
  107.     Stock_date = DateAdd("d", 1, Stock_date)
  108. Loop
  109.     Application.ScreenUpdating = True
  110.     Application.StatusBar = False
  111.     刪除暫存工作表
  112. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 不要小看自己，因為人有無限的可能。
返回列表 上一主題