抓取上市股票代碼如下
Sub 找尋股票代碼() Dim i As Integer, n As Integer Dim stockurl As String Dim RowStart As Range, RowEnd As Range stockurl = "http://isin.twse.com.tw/isin/C_public.jsp?strMode=2" n = 2 If SheetExists("Temp") <> True Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp" '建立指定工作到現存工作表的對後面 Else 清除工作表 "Temp" End If 股票代碼 stockurl With Sheet1 With Sheets("Temp") Sheet1.Cells(1, 1) = "股票代碼" Sheet1.Cells(1, 2) = "公司名稱" n = 2 For i = 2 To .Cells(65535, 1).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 儲存股票代碼(SaveDate As String) Dim TestObj As Object Dim CSVfile As String, CSVfolder As String Dim TestFolder As Boolean Set TestObj = CreateObject("Scripting.FileSystemObject") CSVfolder = FilePath & SaveDate & "\" CSVfile = CSVfolder & SaveDate & ".csv" TestFolder = TestObj.FolderExists(CSVfolder) If TestFolder = False Then TestObj.CreateFolder (CSVfolder) On Error Resume Next Kill CSVfile On Error GoTo 0 Sheet1.Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=CSVfile, FileFormat:=xlCSV Application.DisplayAlerts = True ActiveWorkbook.Close 0 End Sub Sub 股票代碼(StockIDURL As String) Dim xlSheet As Excel.Worksheet Set xlSheet = Sheets("Temp") With xlSheet.QueryTables.Add("URL;" & StockIDURL, xlSheet.Cells(1, 1)) .WebFormatting = xlWebFormattingNone .WebTables = "2" .Refresh 0 .Delete If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗" '被免資料抓取不成功,而顯示訊息 End With Set xlSheet = Nothing End Sub
抓取上市交易明細程式碼如下
Option Explicit Dim IE As Object, doc As Object, element As Object Dim strURL As String, table As String, Pagecount As String, stockid As String, stockname As String Const TempName As String = "Temp" Public FilePath As String Public Enum IE_READYSTATE READYSTATE_COMPLETE = 4 End Enum Function 網頁開啟完成與否() 網頁開啟完成與否 = False With IE '.Visible = True .Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx" Do While .Busy Or .ReadyState <> IE_READYSTATE.READYSTATE_COMPLETE DoEvents Loop Do DoEvents Loop Until .document.ReadyState = "complete" End With 網頁開啟完成與否 = True End Function Sub 執行(pos As Integer, DownloadDate As String) Dim i As Integer, j As Integer, n As Integer, id As Integer Set IE = CreateObject("InternetExplorer.Application") If Not 網頁開啟完成與否 Then MsgBox "證交所買賣日報表查詢系統網頁無法開啟", vbExclamation Exit Sub End If Application.ScreenUpdating = False With Sheet1 n = .Cells(65536, 1).End(xlUp).Row For id = pos To n .Range("D2") = id stockid = .Cells(id, 1) stockname = .Cells(id, 2) 取得明細 Application.StatusBar = DownloadDate + " " + stockid + " " + stockname + "交易明細共有" + Pagecount + "頁" If Pagecount <> "" Then 儲存CSV DownloadDate, stockid If SheetExists("Temp") Then 清除工作表 TempName End If End If Next If SheetExists("Temp") Then 清除工作表 TempName End If .Activate .Range("D2") = 2 End With IE.Quit Application.ScreenUpdating = True Set IE = Nothing End Sub Sub 取得明細() Dim i As Integer, j As Integer 取得交易明細總頁數 If Pagecount = "" Then Exit Sub strURL = "http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & stockid & "&FocusIndex=All_" + Pagecount If Pagecount > 655 Then MsgBox "股票編號" & stockid & "的總交易頁數超出工作表可以儲存的範圍" Exit Sub End If table = "5" For i = 0 To Pagecount + 1 For j = 0 To 1 table = table & "," & CStr(7 + 9 * i + j) Next j Next i If SheetExists(TempName) <> True Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = TempName '建立指定工作到現存工作表的對後面 Else 清除工作表 TempName End If 取得交易明細 strURL, table 刪空特定列 End Sub Sub 取得交易明細總頁數() Dim Retry As Integer Retry = 0 Do Set doc = IE.document Loop While doc Is Nothing Do Pagecount = "" Do Do Set element = doc.getElementsByName("txtTASKNO") Loop While element Is Nothing element.Item(0).Value = stockid Set element = doc.getElementsByName("txtTASKNO") Loop While element.Item(0).Value <> stockid Do Do Set element = doc.getElementsByName("btnOK") Loop While element Is Nothing element.Item(0).Click Do Delay 0.5 Set element = doc.getElementsByName("sp_ListCount") Loop While element Is Nothing Retry = Retry + 1 If Retry = 10 Then Exit Sub Loop While element Is Nothing Delay 0.5 Pagecount = element.Item(0).innerText Loop While Pagecount = "" Set doc = Nothing Set element = Nothing End Sub Sub 取得交易明細1(strURL As String, table As String) Dim xlSheet As Excel.Worksheet Set xlSheet = Sheets("Temp") With xlSheet.QueryTables.Add("URL;" & strURL, xlSheet.Cells(1, 1)) .WebFormatting = xlWebFormattingNone .WebTables = table Do Delay 0.5 On Error Resume Next .Refresh 0 On Error GoTo 0 Loop While Application.Count(.ResultRange) = 0 .Delete 'If Err.Number <> 0 Then Err.Clear: MsgBox Err.Number '被免資料抓取不成功,而顯示訊息 End With End Sub Sub 取得交易明細(strURL As String, table As String) Dim xlSheet As Excel.Worksheet Set xlSheet = Sheets("Temp") Do Application.DisplayAlerts = False With xlSheet.QueryTables.Add("URL;" & strURL, xlSheet.Cells(1, 1)) .WebFormatting = xlWebFormattingNone .WebTables = table On Error Resume Next Do Err.Clear .Refresh 0 If Err.Number Then Application.Wait Now + TimeValue("00:00:01") End If Loop Until Err.Number = 0 .Delete 'If Err.Number <> 0 Then Err.Clear: MsgBox Err.Number '被免資料抓取不成功,而顯示訊息 On Error GoTo 0 End With If Err.Number = 0 Then Application.DisplayAlerts = True Exit Sub End If Loop End Sub Sub 刪空特定列() Dim i As Integer, j As Integer, Record As Integer Worksheets(TempName).Select Record = Cells(65536, 1).End(xlUp).Row j = 0 For i = 6 To Record Rows(i & ":" & i).Select If ActiveCell.Value = Empty Or ActiveCell.Value = "序" Then j = j + 1 Selection.EntireRow.Delete Shift:=xlUp If Record - j >= i Then i = i - 1 End If End If Next End Sub Sub 儲存CSV(SaveDate As String, CSVname As String) Dim TestObj As Object Dim CSVfile As String, CSVfolder As String Dim TestFolder As Boolean CSVfolder = FilePath & SaveDate & "\" CSVfile = CSVfolder & CSVname & "_" & SaveDate & ".csv" Set TestObj = CreateObject("Scripting.FileSystemObject") TestFolder = TestObj.FolderExists(CSVfolder) If TestFolder = False Then TestObj.CreateFolder (CSVfolder) On Error Resume Next Kill CSVfile On Error GoTo 0 Worksheets(TempName).Copy Application.DisplayAlerts = False With ActiveWorkbook .SaveAs Filename:=CSVfile, FileFormat:=xlCSV .Close 0 End With Application.DisplayAlerts = True End Sub Function 清除工作表(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 Function Function SheetExists(strWSName As String) As Boolean Dim Temp As Worksheet On Error Resume Next Set Temp = Worksheets(strWSName) If Not Temp Is Nothing Then SheetExists = True On Error GoTo 0 Exit Function End If SheetExists = False On Error GoTo 0 End Function Function 刪除工作表(sheetname As String) Application.DisplayAlerts = False '關閉警告視窗 Worksheets(sheetname).Select Worksheets(sheetname).Delete '刪除作用中的工作表 Application.DisplayAlerts = True '恢復警告視窗 End Function Public Sub Delay(DelayTime As Single) Dim BeginTime As Single BeginTime = Timer While Timer < BeginTime + DelayTime DoEvents Wend End Sub
iInfo大大,
回覆刪除VBA抓取上市交易明細的程式碼沒有找到 CommandButtom相關的程式碼. 懇求!能將檔案寄送給我參考嗎! 感恩~~~
hotjoe888@hotmail.com
CommandButton你可自行添加
刪除目前有 "Excel VBA 投資數據存取" 課程,會敎基本的VBA語法
有需要可以參考"Excel VBA 投資數據存取" http://white5168.blogspot.tw/2012/11/excel-vba.html