- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
39#
發表於 2015-11-16 07:34
| 只看該作者
回復 38# chang0833
試試看- Option Explicit
- Sub Ex()
- Dim URL As String, xCo_Id As String, X As Integer
- Dim xSyear As Integer, xSseason As Integer, Ar(1 To 4)
- Dim Sh(1 To 2) As Worksheet, AY, Rng As Range, E As Variant
- Dim Wb As Workbook
- For X = 0 To 3
- Ar(X + 1) = 1 + (6 * X) '第一季到第四季的欄位
- Next
- xCo_Id = Application.InputBox("請輸入股票代號", , 2303) '預設為 2303
- X = Year(Date) - 1910 '中華民國的年度
- Application.ScreenUpdating = False
- Set Wb = Workbooks("book1.xls") '指定活頁簿
- With Wb
- Set Sh(1) = .Sheets.Add '新增工作表: 複製季財報到指定工作頁
- Set Sh(2) = .Sheets.Add '新增工作表: WEB查詢用
- End With
- On Error GoTo Er '處理程式上的錯誤
- Sh(1).Name = xCo_Id & "季報表" '這名稱工作表如已存在程式會有錯誤
- On Error GoTo 0 '不在處理程式上的錯誤
-
- For xSyear = X To X - 3 Step -1 '迴圈:年度 '105->102
- 'For xSyear = X - 3 To X '迴圈:年度 '102->105
- For xSseason = 1 To 4 ' '迴圈:季別 '1,2,3,4
- URL = "URL;http://mops.twse.com.tw/server-java/t164sb01?step=1&CO_ID=" & xCo_Id & "&SYEAR=" & xSyear & "&SSEASON=" & xSseason & "&REPORT_ID=C"
- With Sh(2).QueryTables.Add(Connection:=URL, Destination:=Sh(2).[A1])
- .Name = xCo_Id & "_" & xSyear & "_第" & xSseason & "季" 'WEB查詢的名稱
- .AdjustColumnWidth = True '自動調整欄寬
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = "2,3,4" '資產負債表,綜合損益表,現金流量表
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .WebSingleBlockTextImport = False
- .WebDisableDateRecognition = False
- .WebDisableRedirections = False
- .Refresh BackgroundQuery:=False
- If .ResultRange.Rows.Count > 2 Then '有資料
- Set Rng = Sh(1).Cells(1, Ar(xSseason)).Cells(Rows.Count).End(xlUp)
- If Rng.Row > 1 Then Set Rng = Rng.Offset(2)
- .ResultRange.Copy Rng
- Else
- .Delete
- End If
-
- End With
- Next
- Next
- Application.DisplayAlerts = False
- Sh(2).Delete
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- Sh(1).Parent.Save
- MsgBox "Ok"
- Exit Sub
- Er: '處理 xCo_Id &季報表 工作表已存在
- Application.DisplayAlerts = False
- Sheets(xCo_Id & "季報表").Delete
- Application.DisplayAlerts = True
- Resume Next '回到錯誤的程式碼
- End Sub
複製代碼 |
|