抓取股票代碼完成畫面
VBA程式碼如下
Option Explicit Dim Tempsheet As Excel.Worksheet Private Sub 股票代碼_Click() 抓取股票代碼 End Sub Sub 抓取股票代碼() Dim StartTime StartTime = Now If 確認工作表存在("Temp") <> True Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp" End If 清除工作表 ("Temp") 清除工作表 ("Sheet1") Set Tempsheet = Sheets("Temp") Application.ScreenUpdating = False 抓股票代碼 解析股票代碼 Application.ScreenUpdating = True MsgBox "股票代碼資料下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation End Sub Sub 解析股票代碼() Dim i As Integer, n As Integer With Sheet1 .Cells(1, 1) = "股票代碼" .Cells(1, 2) = "公司名稱" n = 2 With Tempsheet For i = 2 To .Cells(65536, 6).End(xlUp).Row If Trim(.Cells(i, 6)) = "ESVUFR" Or _ Trim(.Cells(i, 6)) = "EUOMSR" Or _ Trim(.Cells(i, 6)) = "EMXXXA" Or _ Trim(.Cells(i, 6)) = "ESVUFA" Then Sheet1.Cells(n, 1) = Split(.Cells(i, 1), " ")(0) Sheet1.Cells(n, 2) = Split(.Cells(i, 1), " ")(1) n = n + 1 End If Next i End With End With End Sub Sub 抓股票代碼() With Tempsheet.QueryTables.Add("URL;http://isin.twse.com.tw/isin/C_public.jsp?strMode=4", Tempsheet.Cells(1, 1)) 'strMode=2 上市 strMode=4 上櫃 .WebFormatting = xlWebFormattingNone .WebTables = "2" .Refresh 0 If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗" '被免資料抓取不成功,而顯示訊息 .Delete End With 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 確認工作表存在(strWSName As String) As Boolean Dim Temp As Excel.Worksheet On Error Resume Next Set Temp = Worksheets(strWSName) If Not Temp Is Nothing Then 確認工作表存在 = True On Error GoTo 0 Set Temp = Nothing Exit Function End If 確認工作表存在 = False On Error GoTo 0 Set Temp = Nothing End Function如果覺得自己寫很麻煩,可至這裡下載
沒有留言:
張貼留言