抓取交易明細完成畫面
VBA程式碼如下
Option Explicit '股票類別 '01 水泥工業 '02 食品工業 '03 塑膠工業 '04 紡織纖維 '05 電機機械 '06 電器電纜 '07 化學生技醫療 '08 玻璃陶瓷 '09 造紙工業 '10 鋼鐵工業 '11 橡膠工業 '12 汽車工業 '13 電子工業 '14 建材營造 '15 航運業 '16 觀光事業 '17 金融保險業 '18 金融保險業 '19 綜合企業 '20 其他 '21 化學工業 '22 生技醫療業 '23 油電燃氣業 '24 半導體業 '25 電腦及週邊設備業 '26 光電業 '27 通信網路業 '28 電子零組件業 '29 電子通路業 '30 資訊服務業 '31 其他電子業 Dim Tempsheet As Excel.Worksheet Private Sub 更新股票資料_Click() 抓取股票基本資料 End Sub Sub 抓取股票基本資料() Dim n As Integer Dim StartTime StartTime = Now If 確認工作表存在("Temp") <> True Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp" End If 清除工作表 ("Sheet1") 清除工作表 ("Temp") Application.ScreenUpdating = False Set Tempsheet = Sheets("Temp") If 取得股票資料 = 0 Then MsgBox "無法抓取股票資料" Exit Sub End If Application.StatusBar = "正在轉換資料,請稍後......" With Sheet1 .Cells(1, 1) = "股票代碼" .Cells(1, 2) = "公司名稱" n = 取得公司間數 Tempsheet.Range("A1:B" & n).Copy '目前只列出股票代碼、公司名稱,如有需要其他欄位,請自行變更 .Cells(2, 1).Select .Paste End With Application.StatusBar = "股票基本資料抓取完成" Application.ScreenUpdating = True MsgBox "股票基本資料下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation End Sub Sub 清除工作表(xlWSName As String) Dim qyt As QueryTable With Worksheets(xlWSName) For Each qyt In .QueryTables qyt.Delete Next .Cells.Clear .Cells.ClearContents End With End Sub Function 取得公司間數() Dim i As Integer, j As Integer, n As Integer j = 0 取得公司間數 = 0 With Tempsheet n = .Cells(65536, 1).End(xlUp).Row For i = 1 To n If .Cells(i, 1).Value = Empty Or _ .Cells(i, 1).Value = "代號" Or _ .Cells(i, 1).Value = "公司" Then j = j + 1 .Rows(i & ":" & i).Delete Shift:=xlUp If n - j >= i Then i = i - 1 End If End If Next 取得公司間數 = .Cells(65536, 1).End(xlUp).Row End With End Function Function 取得股票資料() Dim xlURL As String Application.StatusBar = "從Web取得股票資料中,請稍後......" xlURL = "http://mops.twse.com.tw/mops/web/ajax_t51sb01?step=1&firstin=1&TYPEK=sii" '上市 sii, 上櫃 otc With Tempsheet.QueryTables.Add("URL;" & xlURL, Tempsheet.Cells(1, 1)) .WebFormatting = xlWebFormattingNone .WebTables = "2" .Refresh 0 If Application.Count(.ResultRange) = 0 Then 取得股票資料 = 0 Exit Function End If 取得股票資料 = Application.Count(.ResultRange) .Delete End With End Function Function 確認工作表存在(xlWSName As String) As Boolean On Error Resume Next Dim xlTemp As Excel.Worksheet Set xlTemp = Worksheets(xlWSName) If Not xlTemp Is Nothing Then 確認工作表存在 = True On Error GoTo 0 Set xlTemp = Nothing Exit Function End If 確認工作表存在 = False On Error GoTo 0 Set xlTemp = Nothing End Function如果覺得自己寫很麻煩,可至這裡下載
沒有留言:
張貼留言