12345678910
返回列表 上一主題 發帖

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
16# 跳轉到 »
發表於 2014-4-24 20:49 | 只看該作者
回復 15# GBKEE
Sorry，剛剛註解是有看了，不過不太懂意思，原來是要把先前#10的程式碼放到模組中，之後就解決了
VBA執行大量迴圈後似乎會佔用記憶體的空間，導致迴圈的執行到後面會越來越慢，不知道我的觀念對不對
目前正在搜索有關釋放記憶體的文章，再次大力感謝GBKEE大大不厭其煩的指導^^:handshake

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
15#
發表於 2014-4-24 20:11 | 只看該作者
回復 14# smart3135
註解有在看嗎? 要複製第10#的 MkDir_Sub 程式到模組上.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
14#
發表於 2014-4-24 19:54 | 只看該作者
回復 13# GBKEE
抱歉，GBKEE大大，圖片中的語法一開始就執行錯誤，不知道是否語法有誤，這段語法真的看不懂，再請您教導一下，感謝！

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
13#
發表於 2014-4-24 16:55 | 只看該作者
本帖最後由 GBKEE 於 2014-4-24 17:04 編輯

回復 12# smart3135
  1. Option Explicit
  2. Sub 抓季損益表資料()
  3.     Dim E As Integer, URL As String, xPath As String, xFile As String
  4.     Dim Msg As Boolean
  5.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
  6.     xPath = "C:\季損益表"
  7.     With ThisWorkbook
  8.         With .Sheets(1)      '活頁簿的第 1 張工作表
  9.             If .QueryTables.Count = 0 Then
  10.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  11.                     .Refresh BackgroundQuery:=False
  12.                 End With
  13.             End If
  14.             For E = 1339 To 2330
  15. ER:
  16.                 With .QueryTables(1)
  17.                     If Msg = False Then
  18.                       .Connection = URL & E
  19.                     ElseIf Msg Then
  20.                                   'https://djinfo.cathaysec.com.tw/z/zc/zcq/zcq0_1339_ACC.djhtm   損益表(累計季表)
  21.                        .Connection = "URL;https://djinfo.cathaysec.com.tw/z/zc/zcq/zcq0_" & E & "_ACC.djhtm"
  22.                     End If
  23.                     .PreserveFormatting = True
  24.                     .BackgroundQuery = True
  25.                     .RefreshStyle = xlInsertDeleteCells
  26.                     .SaveData = True
  27.                     .AdjustColumnWidth = True
  28.                     .RefreshPeriod = 0
  29.                     .WebSelectionType = xlSpecifiedTables
  30.                     .WebFormatting = xlWebFormattingNone
  31.                     .WebTables = "3"
  32.                     .WebPreFormattedTextToColumns = True
  33.                     .WebConsecutiveDelimitersAsOne = True
  34.                     .Refresh BackgroundQuery:=False
  35.                 End With
  36.                 If InStr(.[A3], "查無") Then Msg = True: GoTo ER
  37.                 If InStr(.[A3], "個股代碼錯誤") = 0 Then '這網頁如股票代碼錯誤會傳回負號.
  38.                      xFile = xPath & "\" & E & "\ISQ.txt"
  39.                     MkDir_Sub xFile       '10#的程式 'C槽下的季損益表資料夾不需先建立
  40.                     Maketxt xFile, .QueryTables(1)
  41.                 End If
  42.                 Msg = False
  43.             Next
  44.         End With
  45.     End With
  46. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
12#
發表於 2014-4-24 13:41 | 只看該作者
本帖最後由 smart3135 於 2014-4-24 13:43 編輯
回復  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
複製代碼

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
11#
發表於 2014-4-24 10:13 | 只看該作者
回復 8# GBKEE
再補充一下，當抓取資料的網站查無該資料時就會出錯，因為我的連結是抓損益季表(合併財報)，而當個股無合併財報可抓取資料時就會出錯
但查詢損益表(季表)是有資料的，不知VBA程式碼能不能做到當主要網頁資料[損益季表(合併財報)]抓不到時就去抓次要網頁資料[損益表(季表)]


損益季表(合併財報0


損益表(季表)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2014-4-24 10:05 | 只看該作者
本帖最後由 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
9#
發表於 2014-4-24 09:35 | 只看該作者
回復 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有沒有辦法做到這樣的結果
再次懇請大大指點迷津，感謝！

   

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 2014-4-24 09:07 | 只看該作者
本帖最後由 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
7#
發表於 2014-4-24 06:33 | 只看該作者
回復 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

        靜思自在 : 不怕事多，只怕多事。
12345678910
返回列表 上一主題