- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2014-6-2 17:20
| 只看該作者
本帖最後由 GBKEE 於 2014-6-2 17:22 編輯
回復 1# chairmen100
使用單步執行沒又問題 但是 free run Excel 卻又 沒有回應
你的程式有在跑,但太多的迴圈所致,你誤以為沒有回應
修改一下試試看- Sub 每日成交資料()
- Dim Y As String, m As String, D As String, tse_ymd As String, xlyear As String, tse_web As String
- Dim i As Integer, N As Integer, qyt As QueryTable, Dept_Row As Integer, MyStr As String, stkstr As String
- Dim Stock_date As Date, objrange As Range
- Dim URNG As Range, dic As Object, x As Integer, k As Variant, Msg As Boolean
- ' Application.ScreenUpdating = False '註解掉:看程式有在 Run 的
- Application.DisplayStatusBar = True
- If New確認工作表("TempG") = False Then Worksheets.Add(after:=Worksheets("每日成交資料")).Name = "TempG"
- Sheets("每日成交資料").Select
- 'Stock_date = Sheets("每日成交資料").Range("I1") '日期還要加一天
- If Sheets("每日成交資料").Range("I1") = "" Then
- Stock_date = CDate("2014/4/1")
- Else
- Stock_date = Sheets("每日成交資料").Range("I1") + 1 '日期還要加一天
- End If
- On Error Resume Next
- Do While DateDiff("d", Stock_date, Now()) >= 0
- While Weekday(Stock_date, 2) > 5 'finding work day
- Stock_date = DateAdd("d", 1, Stock_date)
- Wend
- If DateDiff("d", Stock_date, #5/1/2014#) = 0 Then Stock_date = DateAdd("d", 1, Stock_date)
- Y = Format(Year(Stock_date), "0000")
- m = Format(Month(Stock_date), "00")
- D = Format(Day(Stock_date), "00")
- xlyear = CStr(CInt(Y) - 1911)
- tse_ymd = xlyear & "/" & m & "/" & D
- Set objrange = Sheets("每日成交資料").Range("I1:J1").EntireColumn 'shift two col to right
- objrange.Insert (xlShiftToRight)
-
- Sheets("每日成交資料").Range("I1:J1") = Format(Stock_date, "yyyy/mm/dd")
- For i = 1 To 2
- Sheets("TempG").Cells.Clear
- Sheets("TempG").Cells.ClearContents
- Msg = False
- Select Case i
- Case 1
- 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
- stkstr = " 上市股價........"
- Application.StatusBar = "擷取 " & tse_ymd & " " & stkstr
- With Sheets("TempG").QueryTables.Add(Connection:="URL;" & tse_web, Destination:=Sheets("TempG").Range("A1"))
- 'If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"
- .WebFormatting = xlWebFormattingNone
- .WebSelectionType = xlSpecifiedTables
- .WebTables = "10"
- .Refresh 0
- If .ResultRange.Count = 2 Or Err <> 0 Then '"資料查詢失敗"
- Msg = True
- GoTo Next_Do
- End If
- .Delete
- End With
- Case 2
- stkstr = " 上櫃股價........"
- Application.StatusBar = "擷取 " & tse_ymd & " " & stkstr
- 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"
- With Sheets("TempG").QueryTables.Add(Connection:="URL;" & tse_web, Destination:=Sheets("TempG").Range("A1"))
- .WebFormatting = xlWebFormattingNone
- .Refresh 0
- .Delete
- End With
- End Select
- Set dic = CreateObject("scripting.dictionary") '字典物件
- For Each URNG In Sheets("TempG").UsedRange.Columns(1).Cells
- If VBA.IsNumeric(URNG.Value) = True And Len(URNG.Value) = 4 Then
- dic(URNG & "," & URNG(1, 2)) = Array(URNG(1, IIf(i = 1, "C", "H")), URNG(1, IIf(i = 1, "I", "C")))
- ' Call 複製每日成交資料(URNG, "每日成交資料", Dept_Row, i)
- ' Dept_Row = Dept_Row + 1
- End If
- Next
- 'RUN 太多次 Sub 複製每日成交資料, 浪費時間
- With Sheets("每日成交資料") '導入字典物件的key , item
- x = 2
- If [count(每日成交資料!a:a)] = 0 Then '當資料是空白時
- For Each k In dic.keys
- .Cells(x, "a") = Split(k, ",")(0)
- .Cells(x, "b") = Split(k, ",")(1)
- .Cells(x, "i") = dic(k)(0)
- .Cells(x, "j") = dic(k)(1)
- x = x + 1
- Next
- Else
- Do While .Cells(x, "a") <> ""
- k = .Cells(x, "a") & "," & .Cells(x, "b")
- If dic.exists(k) Then
- .Cells(x, "i") = dic(k)(0)
- .Cells(x, "j") = dic(k)(1)
- dic.Remove k '移除字典物件的key
- End If
- x = x + 1
- Loop
- If dic.Count > 0 Then
- For Each k In dic.keys
- .Cells(x, "a") = Split(k, ",")(0)
- .Cells(x, "b") = Split(k, ",")(1)
- .Cells(x, "i") = dic(k)(0)
- .Cells(x, "j") = dic(k)(1)
- x = x + 1
- Next
- End If
- End If
- End With
- '*********************
- Next
- '============================================================================================================================================================================================
- Next_Do:
- If Msg = True Then Sheets("每日成交資料").Range("I1:J1").EntireColumn.Delete
- Stock_date = DateAdd("d", 1, Stock_date)
- Loop
- Application.ScreenUpdating = True
- Application.StatusBar = False
- 刪除暫存工作表
- End Sub
|
|
發表於 2014-5-15 22:52
| 
