麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼