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

smart3135

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

下載次數: 35

2014-4-22 00:54

smart3135

請問一下各位先進，這是我從某網站匯入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

複製代碼

smart3135

回復 3# GBKEE
感謝GBKEE大大指點新手，目前人在上班，等下班再來測試結果，也會試著了解其中的語法，有問題再請您多多指點，再次感謝！

smart3135

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

smart3135

回復 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季損益表的工作表，再重覆上述的動作，問題有點多，希望我表達的意思不會太難懂，再麻煩大大囉！感謝！

smart3135

回復 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有沒有辦法做到這樣的結果
再次懇請大大指點迷津，感謝！

   

下載 (27.44 KB)

2014-4-24 09:34

下載 (22.87 KB)

2014-4-24 09:35

smart3135

回復 8# GBKEE
再補充一下，當抓取資料的網站查無該資料時就會出錯，因為我的連結是抓損益季表(合併財報)，而當個股無合併財報可抓取資料時就會出錯
但查詢損益表(季表)是有資料的，不知VBA程式碼能不能做到當主要網頁資料[損益季表(合併財報)]抓不到時就去抓次要網頁資料[損益表(季表)]

下載 (60.2 KB)

2014-4-24 10:08

損益季表(合併財報0

下載 (48.93 KB)

2014-4-24 10:09

損益表(季表)

下載 (75.75 KB)

2014-4-24 10:10

smart3135

回復  smart3135
試試看
GBKEE 發表於 2014-4-24 09:07

呼！花了點時間慢慢研究一個個程式碼的意思及語法，再將GBKEE版大提供的程式碼稍做修改，終於完成了！現在只要執行VBA就能將我要的ISQ.TXT檔放在
迴圈變數E所產生的資料夾下，也就是C:\季損益表\1101\、C:\季損益表\1102\，唯一要注意的是C槽下的季損益表資料夾一定要自己先建立，否則執行程式時會出錯
現在就只剩下上一篇提出的問題：當抓取網頁資料時若無資料要如何跳過或去抓取有資料的網頁以避免出錯，再請GBKEE大大指點囉！感恩！

1. Option Explicit
   
2. Sub 抓季損益表資料()
   
3.     Dim E As Integer, URL As String, xPath As String, ISQ As String
   
4.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
   
5.     For E = 1101 To 2330
   
6.         xPath = "C:\" & "季損益表" & "\" & E & "\"
   
7.         '存檔路徑是C:\E\XYZ.TXT, 建議改為 C:\季損益表\1101.txt
   
8.         With ThisWorkbook
   
9.            ' If .Sheets.Count = 1 Then .Sheets.Add  '配合讀取txt檔到工作表時必須有2張工作表
   
10.             With .Sheets(1)   '活頁簿的第 1 張工作表
    
11.                 If .QueryTables.Count = 0 Then
    
12.                     With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
    
13.                         .Refresh BackgroundQuery:=False
    
14.                     End With
    
15.                 End If
    
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 & "ISQ.TXT", .QueryTables(1)
    
34.                         'Redalltxt xPath & "\" & E & ".TXT"  '讀取txt檔到工作表
    
35.                     End If
    
36.                
    
37.             End With
    
38.         End With
    
39.     Next
    
40. End Sub
    
41. Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
    
42.     Dim fs As Object, E As Range, C As Variant
    
43.     Set fs = CreateObject("Scripting.FileSystemObject")
    
44.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
    
45.     For Each E In Q.ResultRange.Rows
    
46.         C = Application.Transpose(Application.Transpose(E.Value))
    
47.         C = Join(C, vbTab)
    
48.         fs.WriteLine C
    
49.     Next
    
50.     fs.Close
    
51. End Sub
    
52. Sub Redalltxt(xF As String)   '
    
53.     Dim fs As Object, E, D As New DataObject
    
54.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
    
55.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
    
56.     Set fs = CreateObject("Scripting.FileSystemObject")
    
57.     Set fs = fs.OpenTextFile(xF, 1)
    
58.      E = fs.readall
    
59.     fs.Close
    
60.     With D
    
61.         .SetText E
    
62.         .PutInClipboard
    
63.         With Sheets(2)
    
64.             .UsedRange.Clear
    
65.             .Activate
    
66.             .Range("A1").Select
    
67.             .PasteSpecial Format:="Unicode 文字"
    
68.             .Cells.Font.Size = 12
    
69.             .Cells.Font.Bold = False
    
70.             .Cells.EntireColumn.AutoFit
    
71.         End With
    
72.     End With
    
73. End Sub
    
74. Sub Set_FormDLL()   '新增引用 Microsoft Forms 2.0 Object Library
    
75.     On Error Resume Next
    
76.     FormDLL = "FM20.DLL"
    
77.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
    
78. '2003版的目錄為 C:\windows\system32\ ,你需修改此目錄
    
79. End Sub

複製代碼

smart3135

回復 13# GBKEE
抱歉，GBKEE大大，圖片中的語法一開始就執行錯誤，不知道是否語法有誤，這段語法真的看不懂，再請您教導一下，感謝！

下載 (179.75 KB)

2014-4-24 19:54

smart3135

回復 15# GBKEE
Sorry，剛剛註解是有看了，不過不太懂意思，原來是要把先前#10的程式碼放到模組中，之後就解決了
VBA執行大量迴圈後似乎會佔用記憶體的空間，導致迴圈的執行到後面會越來越慢，不知道我的觀念對不對
目前正在搜索有關釋放記憶體的文章，再次大力感謝GBKEE大大不厭其煩的指導^^:handshake