返回列表 上一主題 發帖

[發問] 可否用迴圈或變數匯入大量資料?

有沒有方法可以用EXCEL VAB抓取上市櫃所有個股的資訊?

想請問各位先進,小弟最近在學EXCEL VBA,想利用EXCEL VBA下載個股的一些資訊,如各季各年的損益表、資產負債表、現金流量表、月營收、年度股利等等資料
目前是有寫出一個EXCEL VBA能抓取單獨個股的資訊,但如果想要更換其他個股,就必須將這個檔案複製另存成另一個檔案,再打開檔案進到visual basic編緝器將
裡面的個股代號以取代的方式變更,如果要這樣一個一個複製完成上市櫃所有的個股excel應該是很沒有效率的,不知道有沒有方法能一次下載很多個股的資料呢?
附上我自己寫的EXCEL VBA,還請各位大大幫忙解惑,感謝!
test.rar (235.84 KB)
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

[發問] 可否用迴圈或變數匯入大量資料?

請問一下各位先進,這是我從某網站匯入EXCEL的程式碼,不知道能不能使用迴圈或變數的方式取其他個股相同的財報?
也就是程式碼中的2330可以用迴圈或變數來變更嗎?懇請各位VBA高手指點,謝謝!
https://www.cathayholdings.com/securities/exclude_AL/market.aspx?btn=1-00-00&st=2330
  1. Sub 抓季損益表資料()
  2.     With ActiveSheet.QueryTables.Add(Connection:= _
  3.         "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=2330", Destination _
  4.         :=Range("$A$1"))
  5.         .Name = "ZCQ.DJHTM?A=2330"
  6.         .FieldNames = True
  7.         .RowNumbers = False
  8.         .FillAdjacentFormulas = False
  9.         .PreserveFormatting = True
  10.         .RefreshOnFileOpen = False
  11.         .BackgroundQuery = True
  12.         .RefreshStyle = xlInsertDeleteCells
  13.         .SavePassword = False
  14.         .SaveData = True
  15.         .AdjustColumnWidth = True
  16.         .RefreshPeriod = 0
  17.         .WebSelectionType = xlSpecifiedTables
  18.         .WebFormatting = xlWebFormattingNone
  19.         .WebTables = "3"
  20.         .WebPreFormattedTextToColumns = True
  21.         .WebConsecutiveDelimitersAsOne = True
  22.         .WebSingleBlockTextImport = False
  23.         .WebDisableDateRecognition = False
  24.         .WebDisableRedirections = False
  25.         .Refresh BackgroundQuery:=False
  26.     End With
  27. Sub End
複製代碼
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

回復 2# smart3135
試試看
  1. Option Explicit
  2. Sub 抓季損益表資料()
  3.     Dim Rng As Range, AR(), URL As String, E As Variant
  4.     For E = Sheets.Count To 2 Step -1
  5.         Sheets(E).Delete   '工作表刪除
  6.     Next
  7.     AR = Array(2303, 2485, 2030)
  8.     Sheets(1).Range("A1:A3") = Application.WorksheetFunction.Transpose(AR)
  9.     Set Rng = Sheets(1).Range("A1:A3")
  10.     For Each E In Rng   '迴圈 儲存格
  11.     ' For Each E In AR  '迴圈 也可以用陣列
  12.         With Sheets.Add(, Sheets(1))  '新增工作表
  13.             .Name = E
  14.             URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=" & E
  15.             With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  16.                 .Name = "ZCQ.DJHTM?A=" & E
  17.                 .PreserveFormatting = True
  18.                 .BackgroundQuery = True
  19.                 .RefreshStyle = xlInsertDeleteCells
  20.                 .SaveData = True
  21.                 .AdjustColumnWidth = True
  22.                 .RefreshPeriod = 0
  23.                 .WebSelectionType = xlSpecifiedTables
  24.                 .WebFormatting = xlWebFormattingNone
  25.                 .WebTables = "3"
  26.                 .WebPreFormattedTextToColumns = True
  27.                 .WebConsecutiveDelimitersAsOne = True
  28.                 .Refresh BackgroundQuery:=False
  29.             End With
  30.         End With
  31.     Next
  32. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

回復 3# GBKEE
感謝GBKEE大大指點新手,目前人在上班,等下班再來測試結果,也會試著了解其中的語法,有問題再請您多多指點,再次感謝!
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

回復 3# GBKEE
感謝GBKEE版主的分享,這個真的是太棒了,雖然我裡面很多的程式碼和語法我還是一知半解,但確實是有接近我想要寫出的結果
另外有個問題請教一下,就是AR = Array(2303, 2485, 2030)只能一個一個代號加入,能否寫成用一個區間範圍來設定
例如1101-2330之間所有符合的股票代號,並讓VBA自行判定非股票代碼的數字就不是抓資料,再請指點,感謝!
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

回復 5# smart3135
  1. Option Explicit
  2. Sub 抓季損益表資料()
  3.     Dim E As Integer
  4.     Application.DisplayAlerts = False  '停止系統的警告提示
  5.     For E = 1101 To 2330
  6.         With Sheets.Add(, Sheets(1))   '新增工作表
  7.             .Name = E
  8.             URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=" & E
  9.             With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  10.                 .Name = "ZCQ.DJHTM?A=" & E
  11.                 .PreserveFormatting = True
  12.                 .BackgroundQuery = True
  13.                 .RefreshStyle = xlInsertDeleteCells
  14.                 .SaveData = True
  15.                 .AdjustColumnWidth = True
  16.                 .RefreshPeriod = 0
  17.                 .WebSelectionType = xlSpecifiedTables
  18.                 .WebFormatting = xlWebFormattingNone
  19.                 .WebTables = "3"
  20.                 .WebPreFormattedTextToColumns = True
  21.                 .WebConsecutiveDelimitersAsOne = True
  22.                 .Refresh BackgroundQuery:=False
  23.             End With
  24.             
  25.             If .[A1] = -E Then  '這網頁如股票代碼錯誤會傳回負號.
  26.                 Stop            'STOP 是給你回到工作表驗證用,可刪掉這程式碼
  27.                 ActiveSheet.Delete
  28.             End If
  29.         End With
  30.     Next
  31.     Application.DisplayAlerts = True   '程式結速:恢復系統的警告提示
  32. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

回復 6# GBKEE
感謝版主的回答,另外想再請教一個問題,不知道VBA有沒有辦法將我抓取下來的資料貼到記事本再自動存檔
之前有嚐試過,但EXCEL VBA似乎沒法控制EXCEL以外的軟體或程式,後來我是使用EXCEL另存新檔中的存成
文字檔(tab字元分隔)(*txt),這樣可以存成文字檔,不過不知道存檔的路徑資料夾有沒有辦用先前做出迴圈的變數E來指定
例如:我想將抓取下來的1101季損益表先放到sheet(1),再另存成XYZ.TXT,存檔路徑是C:\E\XYZ.TXT
其中E就是我希望能隨著抓取的股票代號一起變更的變數,也就是若抓取的資料是1101,那麼存檔路徑就是C:\1101\XYZ.TXT
存檔路徑資料夾若VBA有辦法利用程式碼新增當然最好,如果沒辦法的話我可以自己建立,完成後將1101季損益表的工作表刪除,
再新增下一個1102季損益表的工作表,再重覆上述的動作,問題有點多,希望我表達的意思不會太難懂,再麻煩大大囉!感謝!
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

本帖最後由 GBKEE 於 2014-4-24 09:11 編輯

回復 7# smart3135
試試看
  1. Option Explicit
  2. Sub 抓季損益表資料()
  3.     Dim E As Integer, URL As String, xPath As String
  4.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
  5.     xPath = "C:\季損益表"
  6.     '存檔路徑是C:\E\XYZ.TXT, 建議改為 C:\季損益表\1101.txt
  7.     With ThisWorkbook
  8.        ' If .Sheets.Count = 1 Then .Sheets.Add  '配合讀取txt檔到工作表時必須有2張工作表
  9.         With .Sheets(1)   '活頁簿的第 1 張工作表
  10.             If .QueryTables.Count = 0 Then
  11.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  12.                     .Refresh BackgroundQuery:=False
  13.                 End With
  14.             End If
  15.             For E = 1101 To 2330
  16.                 With .QueryTables(1)
  17.                     .Connection = URL & E
  18.                     .PreserveFormatting = True
  19.                     .BackgroundQuery = True
  20.                     .RefreshStyle = xlInsertDeleteCells
  21.                     .SaveData = True
  22.                     .AdjustColumnWidth = True
  23.                     .RefreshPeriod = 0
  24.                     .WebSelectionType = xlSpecifiedTables
  25.                     .WebFormatting = xlWebFormattingNone
  26.                     .WebTables = "3"
  27.                     .WebPreFormattedTextToColumns = True
  28.                     .WebConsecutiveDelimitersAsOne = True
  29.                     .Refresh BackgroundQuery:=False
  30.                 End With
  31.                 If .[A1] <> -E Then  '這網頁如股票代碼錯誤會傳回負號.
  32.                     If Dir(xPath, vbDirectory) = "" Then MkDir xPath '目錄不存在則新徵增此目錄
  33.                     Maketxt xPath & "\" & E & ".TXT", .QueryTables(1)
  34.                     'Redalltxt xPath & "\" & E & ".TXT"  '讀取txt檔到工作表
  35.                 End If
  36.             Next
  37.         End With
  38.     End With
  39. End Sub
  40. Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  41.     Dim fs As Object, E As Range, C As Variant
  42.     Set fs = CreateObject("Scripting.FileSystemObject")
  43.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  44.     For Each E In Q.ResultRange.Rows
  45.         C = Application.Transpose(Application.Transpose(E.Value))
  46.         C = Join(C, vbTab)
  47.         fs.WriteLine C
  48.     Next
  49.     fs.Close
  50. End Sub
  51. Sub Redalltxt(xF As String)   '
  52.     Dim fs As Object, E, D As New DataObject
  53.     'DataObject 物件 在進行轉換動作時,做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  54.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  55.     Set fs = CreateObject("Scripting.FileSystemObject")
  56.     Set fs = fs.OpenTextFile(xF, 1)
  57.      E = fs.readall
  58.     fs.Close
  59.     With D
  60.         .SetText E
  61.         .PutInClipboard
  62.         With Sheets(2)
  63.             .UsedRange.Clear
  64.             .Activate
  65.             .Range("A1").Select
  66.             .PasteSpecial Format:="Unicode 文字"
  67.             .Cells.Font.Size = 12
  68.             .Cells.Font.Bold = False
  69.             .Cells.EntireColumn.AutoFit
  70.         End With
  71.     End With
  72. End Sub
  73. Sub Set_FormDLL()   '新增引用 Microsoft Forms 2.0 Object Library
  74.     On Error Resume Next
  75.     FormDLL = "FM20.DLL"
  76.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  77. '2003版的目錄為 C:\windows\system32\ ,你需修改此目錄
  78. End Sub
複製代碼
EX.JPG
2014-4-24 09:11
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

回復 8# GBKEE
WOW,GBKEE版主真的太神了,裡面的語法有好多還看不懂,目前正用逐行執行來了解,慢慢消化吸收,很感謝您的回答
不過可能我前面表達的不是很清楚,就您的程式碼來說,產生的結果會變成在C:\季損益表\1101.txt,1102.txt,1103.txt
也就是在C槽季損益表資料夾下會產生一個個照個股代碼命名的txt檔,但我希望產生的結果是C:\季損益表\1101\ISQ.txt
C:\季損益表\1102\ISQ.txt,C:\季損益表\1103\ISQ.txt,也就是txt檔名是固定的,由我自己指定檔名,這裡是先預設ISQ.txt
而能隨著個股代碼變動的是資料夾名稱,資料夾若無法由VBA產生我可以自行建立,不知道VBA有沒有辦法做到這樣的結果
再次懇請大大指點迷津,感謝!

   
1101.jpg
2014-4-24 09:34

ISQ.jpg
2014-4-24 09:35
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

本帖最後由 GBKEE 於 2014-4-25 05:45 編輯

回復 9# smart3135
  1. Option Explicit
  2. Sub Ex()
  3.     MkDir_Sub "D:\Test\季損益表\1103\ISQ.txt"
  4. End Sub
  5. Sub MkDir_Sub(S As String)
  6.     Dim AR, i As Integer, xPath As String
  7.     If Dir(S) = "" Then
  8.         AR = Split(S, "\")
  9.         '如S參數所接收字串="D:\MYSUB\ABC\1101.TXT
  10.         'Split函數將S以"\"分割為陣列
  11.         'AR(0) = "D:"
  12.         'AR(1) = "MYSUB"
  13.         'AR(2) = "ABC"
  14.         'AR(3) = "1101.TXT"
  15.         'UBound(AR)傳回AR陣列的上限元素索引值,3
  16.         xPath = AR(0)
  17.         For i = 1 To UBound(AR) - 1
  18.             xPath = xPath & "\" & AR(i)
  19.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  20.             'MkDir : 創建目錄
  21.         Next
  22.     End If
  23. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.
請詳閱 論壇版規愛惜帳號,一起創造美好的學習討論空間。

TOP

        靜思自在 : 改變自己是自救,影響別人是救人。
返回列表 上一主題