123456
返回列表 上一主題 發帖

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
21# 跳轉到 »
發表於 2014-4-27 09:55 | 顯示全部帖子
回復 27# GBKEE
GBKEE版主早安，有些問題想請教您：
1.今早下班回來就馬上試了您昨天在27#提供的程式碼，我有再加上要跳過的代號在AR中，也照提示將代號都輸入到sheet(2)的A欄
直接跑一次，奇怪的事發生了，我設定For E = 1101 to 5000，每次跑到一半時就會出錯，出錯的位置是在If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then，不清楚哪裡出了問題
附上程式碼和檔案，請您幫忙看看　
2.另外我有發現您27#的程式碼在出錯前的執行時速度非常快，和您先前提供的程式碼讓我在23#完成的程式有很大的落差，這當中究竟有什麼差異呢？為什麼速度會差這麼多呢？
一樣我兩個VBA程式都有附上，也麻煩您幫忙看看為什麼會有如此大的差異
3.我用您先前提供的跑下來，第一段1101 to 5000，費時12分48秒，抓了992筆資料
第二段5001 to 9962，費時13分50秒，抓了515筆資料
我在跑第二段時有先使用清除系統的.bat檔，並將EXCEL關閉再開啟重新執行VBA，結果看來並沒有瘦身的效果，不知道為什麼會這樣？
4.另外在將資料匯入txt的程式碼中，如下
   For Each E In Q.ResultRange.Rows
        C = Application.Transpose(Application.Transpose(E.Value))
        C = Join(C, vbTab)
        fs.WriteLine C
    Next
其中Q.ResultRange.Rows的Rows是不是代表列，也就是將資料一列一列存入txt，直到沒有資料為止
之後我有想到，因為用一列一列的方式來匯入資料要跑很多次迴圈，如果是用一欄一欄的方式匯入就會少跑很多次迴圈
我有試著將Rows改為Columns，但執行到下二行的C = Join(C, vbTab)就會出錯，不知道有沒有辦法用欄的方式匯入呢？

問題有點多，再麻煩您幫忙一下囉！感謝！
  1. Option Explicit
  2. Sub 抓季月營收資料()
  3.     Dim E As Integer, URL As String, xPath As String, xFile As String
  4.     Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
  5.     Dim AR()
  6.     t = Time
  7.     AR = Array(1202, 1420, 1433, 1502, 1518, 1610, 1716, 2346, 2372, 2391, 2513, 2526, 2541, 2802, 2803, 2804, 2806, _
  8.             2813, 2814, 2815, 2817, 2818, 2819, 2821, 2826, 2830, 2839, 2840, 2843, 2844, 2848, 2907, 2909, 4101, 4112, _
  9.             4175, 4201, 4203, 4204, 4301, 4302, 4405, 4407, 4409, 4410, 4411, 4412, 4504, 4505, 4507, 4508, 4509, 4512, _
  10.             4514, 4516, 4517, 4519, 4520, 4521, 4524, 4525, 4531, 4603, 4604, 4605, 4606, 4607, 4608, 4701, 4704, 4705, _
  11.             4708, 4709, 4710, 4713, 4715, 4718, 4901, 4902, 5001, 5003, 5004, 5005, 5012, 5101, 5311, 5319, 5320, 5322, _
  12.             5323, 5327, 5330, 5331, 5334, 5335, 5337, 5341, 5342, 5354, 5357, 5358, 5359, 5360, 5361, 5362, 5363, 5366, _
  13.             5368, 5369, 5374, 5377, 5379, 5380, 5382, 5389, 5391, 5393, 5394, 5396, 5397, 5399, 5404, 5405, 5408, 5409, _
  14.             5411, 5412, 5415, 5416, 5417, 5418, 5419, 5420, 5421, 5422, 5423, 5424, 5427, 5428, 5430, 5431, 5433, 5435, _
  15.             5440, 5444, 5445, 5446, 5447, 5449, 5453, 5456, 5458, 5459, 5461, 5462, 5463, 5470, 5472, 5476, 5477, 5482, _
  16.             5485, 5486, 5495, 5496, 5499, 5509, 5517, 5527, 5606, 5705, 5804, 5805, 5806, 5807, 5809, 5812, 5814, 5815, _
  17.             5854, 6003, 6006, 6019, 6102, 6106, 6401, 6501, 8001, 8003, 8903, 8904, 8912, 8914, 8915, 8918, 8920, 8922, 8939, 9105, 9909)
  18.             '輸入 4203天仁(後抓取)是錯誤的股票號碼
  19.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
  20.     xPath = "G:\財報資料"
  21.     With ThisWorkbook
  22.         .Sheets(2).UsedRange.Offset(, 1).Clear
  23.         '4203天仁(後抓取)是錯誤的股票號碼 這些 股票名稱(代號) 連續一起輸入在Sheets(2)的A欄
  24.         Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
  25.         If Rng Is Nothing Then
  26.             AR = Array()
  27.         ElseIf Rng.Count = 1 Then
  28.             AR = Array(Rng.Value)
  29.         Else
  30.             AR = Application.Transpose(Application.Transpose(Rng))
  31.         End If        '***************************************************
  32.         Application.ScreenUpdating = False
  33.         Application.StatusBar = " "
  34.         With .Sheets(1)      '活頁簿的第 1 張工作表
  35.             If .QueryTables.Count = 0 Then
  36.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  37.                     .Refresh BackgroundQuery:=False
  38.                 End With
  39.             End If
  40.                 .Rows(1).Delete
  41.                 .Columns(1).Delete
  42.             For E = 1101 To 5000
  43.                 With .QueryTables(1)
  44.                     .Connection = URL & E
  45.                     .PreserveFormatting = True
  46.                     .BackgroundQuery = True
  47.                     .RefreshStyle = xlInsertDeleteCells
  48.                     .SaveData = True
  49.                     .AdjustColumnWidth = True
  50.                     .RefreshPeriod = 0
  51.                     .WebSelectionType = xlSpecifiedTables
  52.                     .WebFormatting = xlWebFormattingNone
  53.                     .WebTables = "3"
  54.                     .WebPreFormattedTextToColumns = True
  55.                     .WebConsecutiveDelimitersAsOne = True
  56.                     .Refresh BackgroundQuery:=False
  57.                     If .ResultRange(1) < 0 Or InStr(.ResultRange(2, 1), "查無") Then GoTo xLnext
  58.                     '匯入資料的 A1 < 0  OR  匯入資料的 A2 "查無"
  59.                     S1 = .ResultRange(1)
  60.                     S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
  61.                 End With
  62.                 With ThisWorkbook.Sheets(2).Range("B:B")
  63.                     Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
  64.                     If Rng Is Nothing Then
  65.                         i = i + 1
  66.                         .Range("A" & i) = S1  '股票名稱代碼
  67.                     Else
  68.                         Rng.Cells(1, 2) = S1   '重複的股票
  69.                         If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then
  70.                         'Filter(AR, E) > -1   '比對到如4203天仁(後抓取)是錯誤
  71.                             Rng.Cells(1, 2) = Rng.Cells(1, 2) & "***" '後抓取是錯誤
  72.                             GoTo xLnext:
  73.                         End If
  74.                         S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
  75.                         S2 = Mid(S2, 1, Len(S2) - 1)    '舊的股票[代碼]
  76.                         xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
  77.                         If Dir(xFile) <> "" Then
  78.                             ii = ii - 1
  79.                             Kill xFile
  80.                             xFile = xPath & "\" & S2
  81.                             If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
  82.                         End If
  83.                     End If
  84.                 End With
  85.                 ii = ii + 1
  86.                 xFile = xPath & "\" & E & "\REVENUE.txt"
  87.                 MkDir_Sub xFile
  88.                 Maketxt xFile, .QueryTables(1)
  89. xLnext:
  90.                 S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
  91.                 If Val(S1) < 0 Then S1 = " 查無"
  92.                 Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & "  " & E & S1
  93.             Next
  94.         End With
  95.     End With
  96.     Application.ScreenUpdating = True
  97.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " Ok "
  98.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  99. End Sub
  100. Private Sub MkDir_Sub(s As String)
  101.     Dim AR, i As Integer, xPath As String
  102.     If Dir(s) = "" Then
  103.         AR = Split(s, "\")
  104.         xPath = AR(0)
  105.         For i = 1 To UBound(AR) - 1
  106.             xPath = xPath & "\" & AR(i)
  107.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  108.         Next
  109.     End If
  110. End Sub
  111. Private Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  112.     Dim fs As Object, E As Range, C As Variant
  113.     Set fs = CreateObject("Scripting.FileSystemObject")
  114.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  115.     For Each E In Q.ResultRange.Rows
  116.         C = Application.Transpose(Application.Transpose(E.Value))
  117.         C = Join(C, vbTab)
  118.         fs.WriteLine C
  119.     Next
  120.     fs.Close
  121. End Sub
複製代碼
兩個月營收VBA.zip (38.38 KB)

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
22#
發表於 2014-4-28 07:23 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-28 07:29 編輯

回復 35# GBKEE
感謝GBKEE版主這幾天來不斷的教導，真的讓我在EXCEL VBA上學習到很多，其他仍有許多需要擷取的資料，如資產負債表 現金流量表等，這些我都能用這幾天學到的
稍加修改就能完成，唯獨有兩種資料比較特別，我無法獨立完成，所以又要再來請教GBKEE版主了
1.
上櫃月成交資訊
　上面連結為上櫃個股月成交資訊，即使輸入個股代號，網址仍不變，據了解是因為網頁為POST，並非GET，所以沒辦法擷取報表
　不知道有沒有辦法也用VBA做迴圈來擷取資料？(在EXCEL匯入WEB資料時似乎沒法等到下面的成交資訊表格來匯入資訊)
2.請件兩個EXCEL附件，這是在網路上面找到的，主要是要抓一年內的集保資料，但都只能用自行輸入的方式來一個一個擷取資料
　不知道有沒有辦法也用類似這兩天您所提供的程式碼來抓取集保資料，結果就如附件中的TXT檔，再麻煩您指點一下囉！感謝！
   
集保資料

[attach]18178[/attach]

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
23#
發表於 2014-4-28 07:41 | 顯示全部帖子
回復 35# GBKEE
抱歉 檔案不知道為什麼上傳失敗 所以再上傳一次
集保資料.zip (74.96 KB)

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
24#
發表於 2014-4-28 13:13 | 顯示全部帖子
回復 38# GBKEE
GBKEE版主您好，這個程式碼我有試了，可以成功，不過不知道為什麼跑起來非常慢，上櫃公司統計共663家，我將它輸入到Sheets(3)的A欄
跑一個文字檔的時間大約要4-5秒，確定有清理系統了，不過還是非常慢
另外有辦法像之前將匯入資料顯示在EXCEL以便逐行執行時可以看出EXCEL如何變化，麻煩您了，謝謝！
  1. Option Explicit
  2. Dim IE As Object
  3. Sub IE_Application()
  4.     Set IE = CreateObject("InternetExplorer.Application")
  5.     With IE
  6.         .Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
  7.      '   .Visible = True   '不顯示ie
  8.         Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
  9.   End With
  10. End Sub
  11. Sub 上櫃月成交資訊()
  12.     Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
  13.     Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
  14.     Set fs = CreateObject("Scripting.FileSystemObject")
  15.     IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
  16.     t = Time
  17.     Application.DisplayStatusBar = True
  18.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  19.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  20.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  21.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  22.     xPath = "G:\財報資料"
  23.     IE_Application    '
  24.     Application.StatusBar = " "
  25.     For Each E In Rng
  26.         With IE
  27.             Set A = .Document.getelementbyid("input_stock_code")
  28.             A.Value = E
  29.             A.ParentNode.submit
  30.             Do While .Busy Or .ReadyState <> 4:    Loop
  31.             Set A = .Document.getelementsbytagname("TABLE")
  32.             xFile = xPath & "\" & E & "\HPM.txt"
  33.             MkDir_Sub xFile
  34.             With fs.CreateTextFile(xFile, True)
  35.                 For i = 1 To A(2).Rows.Length - 1
  36.                     S = ""
  37.                     For C = 0 To A(2).Rows(i).Cells.Length - 1
  38.                         S = S & A(2).Rows(i).Cells(C).innertext & vbTab
  39.                     Next
  40.                     .WriteLine S
  41.                 Next
  42.                 .Close
  43.             End With
  44.             ii = ii + 1
  45.         End With
  46.         Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  47.     Next
  48.     IE.Quit
  49.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔,  讀取完畢 !! "
  50.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  51.     ThisWorkbook.Save
  52. End Sub
  53. Sub MkDir_Sub(S As String)
  54.     Dim AR, i As Integer, xPath As String
  55.     If Dir(S) = "" Then
  56.         AR = Split(S, "\")
  57.         xPath = AR(0)
  58.         For i = 1 To UBound(AR) - 1
  59.             xPath = xPath & "\" & AR(i)
  60.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  61.         Next
  62.     End If
  63. End Sub
  64. Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  65.     Dim fs As Object, E As Range, C As Variant
  66.     Set fs = CreateObject("Scripting.FileSystemObject")
  67.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  68.     For Each E In Q.ResultRange.Rows
  69.         C = Application.Transpose(Application.Transpose(E.Value))
  70.         C = Join(C, vbTab)
  71.         fs.WriteLine C
  72.     Next
  73.     fs.Close
  74. End Sub
複製代碼

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
25#
發表於 2014-4-28 19:14 | 顯示全部帖子
回復 40# GBKEE
版主您好，剛剛將電腦關閉後重新開啟後再重新執行VBA，結果很不錯，一個平均一秒多，可能之前我在執行VBA時開啟太多其他軟體了

這個是擷取年成交資訊，還有一個月成交資訊，因為月成交資訊是要點月份來選擇，我會先自己做看看，不行的話會再來向您討教
另外您附上的集保資料我還沒試，晚上會利用時間來試試，不過我有稍微瞄了一下，有看到INPUT BOX，因為我是要用迴圈連續擷取資料
不是要用INPUT BOX輸入代碼來擷取資料，也不需要附檔的圖，只需要文字檔內容即，不知道我是否解讀錯誤，會利用時間了解看看，再次感謝您！

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
26#
發表於 2014-4-29 11:17 | 顯示全部帖子
回復 38# GBKEE
GBKEE版主早安，我在抓上市個股年成交資訊又遇到問題了，原本是想利用您在37#的抓取上櫃年成交的程式碼來修改，但卻出錯，能請您再幫忙看一下嗎？
另外因為希望將匯入資料的EXCEL表格做一些修改再存入txt，所以我也有用先前抓其他資料的VBA來測試，但因為先前連結的網站是國泰證券，需要的資料只要將
最後的個股代碼設定成迴圈變數，就能將資料一個一個擷取下來，但上市年成交資訊的網頁不是這樣的格式，所以不清楚該怎麼做迴圈設定擷取資訊
請您再指點一下，如果可以的話，希望兩種都能學，附上兩個EXCEL VBA以及連結的資訊
test.zip (37.88 KB)

"URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCC/ZCC.DJHTM?A=2330"    >>>>>>>>>這是先前利用國泰證券做的連結網址，只要將最後改成迴圈變數就可以了

"URL;http://www.twse.com.tw/ch/trading/exchange/FMNPTK/genpage/Report201404/2330_F3_1_11.php?STK_NO=2330&myear=2014&mmon=04"
這是證交所上市個股2330的年成交資訊連結，不知道有沒有辦法用迴圈變數做連結

"URL;http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"      >>>>>>>>>>>>>>這是證交所上市個股年成交資訊首頁


這張圖就是想要抓的表格，上面有提到希望能先匯到EXCEL再存到文字檔就是希望年的順序可以反過來，也就是越新的年度排越上面，另外資料在匯入EXCEL後會將
(元,股)也變成一列，這一列也希望能刪除

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
27#
發表於 2014-5-1 20:30 | 顯示全部帖子
回復 43# GBKEE
不好意思，GBKEE版主，請問是搜尋 http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php這字串嗎？
因為我在版上搜索這字串是查無結果的，所以想跟您確認一下，我也想好好學習網頁建置不同上的差別在哪？謝謝您！

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
28#
發表於 2014-5-2 05:12 | 顯示全部帖子
回復 43# GBKEE
哈囉！GBKEE版主，又來向您討教囉！關於在43#的程式碼在sheet(3)的A欄套用上市個股代號後是可行的，但若我想將網址改成月成交資訊
會多了一個"年"查詢欄，又該如何設定"年"的查詢欄位可以多查幾年呢？例如首頁是直接跳出103年，再輸入股票代碼即可查詢，我想將102年、101年的資料
也一起匯入，應該怎麼做變化呢？我想關鍵是不是在以下的程式碼，因為對內容的語法不太了解，所以想再來請教您一下！
我若直接將月成交資訊的網址帶入，只能匯入103年的資料，不知道是不是各年度的月成交資訊能像股票代碼一樣在sheet(3)的某欄位輸入當成迴圈
就能匯入需要的資料，例如我想要103、102、101、100年的月成交資訊，就在sheet(3)的B欄從上往下key入，再做一些程式碼的變更就能讓程式去依照
sheet(3)的B欄輸入的年份匯入月成交資訊，不知這樣的想法對不對，再請您指點一番！謝謝！
　　　Do While .Busy Or .ReadyState <> 4:    Loop
            Set A = .Document.getelementbyid("STK_NO")
            A.Value = E
             .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
            Do While .Busy Or .ReadyState <> 4:    Loop
            Set A = .Document.getelementsbytagname("TABLE")


上櫃月成交資訊




上市月成交資訊

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
29#
發表於 2014-5-4 06:02 | 顯示全部帖子
回復 38# GBKEE
GBKEE版主您好，又來向您討教了，因為先前不懂為什麼查詢上市與上櫃年成交資訊的VBA程式碼中分別有"STK_NO"與"input stock code"，之後才想到是要去找網頁原紿碼
雖然大部分都看不懂，不過確實是分別在上市與上櫃年成交資訊的網頁原始碼中找到上述兩個字串，我想這應該是必定要寫在VBA中的關鍵字串，後來去查了一下上櫃的月成交資訊
有看到多出日期欄的字串，測試了將字串寫入VBA，但卻會出錯，嘗試多次變更仍無法順利執行，不知該如何將這些字串正確地寫入VBA，當然上市的月成交資訊
測試結果也和上櫃的一樣，都是無功而返，所以只能再度叨擾您了，懇請您再次賜教，感謝！
test.zip (17.84 KB)

上櫃年成交資訊


上櫃月成交資訊

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
30#
發表於 2014-5-5 05:57 | 顯示全部帖子
回復 47# GBKEE
感謝版主耐心的回答，看了文章之後，大概了解了相對引數的關鍵字，也有試著將相對引數"select"和"yy"代入，結果是可行的
不過有點問題：
1.在迴圈執行程式時是會依照我在sheet(3) B欄輸入的年份匯入文字檔，不過下一年份的資料又會覆蓋原來的文字檔內容
    例如我在sheet(3) B欄輸入的年份是2014、2013、2012，結果2014的寫完後再寫下一筆的2013就會把原來寫入的2014覆蓋掉
    不知道能不能將三年的資料都寫入文字檔？
2.年份迴圈是否只能利用像個股代號一樣在sheet(3) 某欄輸入想要擷取的年份資料，能不能直接寫入VBA中呢？
3.寫入的文字檔是從開始有數字資料時寫起，不知道能不能由最上方個股代號那一列開始寫入，也就是文字檔中會看得到個股代號
4.因為這個VBA程式是直接將資料寫入文字檔，無法看到資料匯入EXCEL的動作，不知道能不能做日期排序
    例如寫入的第一年份資料由上到下是103年1月份到103年5月份，不知道能不能將5月份寫到最上方
我想問題會這麼多，應該是我VBA基礎還沒打好就急於學習更進階的東西，看來我可能得多看些書、文章、影片充實自己的VBA基礎，很感謝版主連日來不厭其煩的回答！

  1. Option Explicit
  2. Dim IE As Object
  3. Sub IE_Application()
  4.     Set IE = CreateObject("InternetExplorer.Application")
  5.     With IE
  6.         .Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
  7.      '   .Visible = True   '不顯示ie
  8.         Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
  9.   End With
  10. End Sub
  11. Sub 上櫃月成交資訊()
  12.     Dim E, X As Range, xPath As String, xFile As String, A, B As Object, fs As Object, F As Object, IE_URL As String
  13.     Dim i As Integer, ii As Integer, t As Date, AR(), Rng, Rng1 As Range, r, C, S
  14.     Set fs = CreateObject("Scripting.FileSystemObject")
  15.     IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
  16.     t = Time
  17.     Application.DisplayStatusBar = True
  18.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  19.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  20.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  21.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  22.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  23.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  24.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  25.     xPath = "D:\財報資料"
  26.     IE_Application    '
  27.     Application.StatusBar = " "
  28.     For Each E In Rng
  29.         For Each X In Rng1
  30.             With IE
  31.                 Set B = .document.getelementsbytagname("select")("yy")
  32.                 B.Value = X
  33.                 Set A = .document.getelementbyid("input_stock_code")
  34.                 A.Value = E
  35.                 A.ParentNode.submit
  36.                 Do While .Busy Or .ReadyState <> 4:    Loop
  37.                 Set A = .document.getelementsbytagname("TABLE")
  38.                 xFile = xPath & "\" & E & "\HPM.txt"
  39.                 MkDir_Sub xFile
  40.                 With fs.CreateTextFile(xFile, True)
  41.                     For i = 1 To A(2).Rows.Length - 1
  42.                         S = ""
  43.                         For C = 0 To A(2).Rows(i).Cells.Length - 1
  44.                             S = S & A(2).Rows(i).Cells(C).innertext & vbTab
  45.                         Next C
  46.                         .WriteLine S
  47.                     Next i
  48.                     .Close
  49.                 End With
  50.             ii = ii + 1
  51.             End With
  52.         Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  53.         Next X
  54.     Next E
  55.     IE.Quit
  56.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔,  讀取完畢 !! "
  57.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  58.     ThisWorkbook.Save
  59. End Sub
  60. Sub MkDir_Sub(S As String)
  61.     Dim AR, i As Integer, xPath As String
  62.     If Dir(S) = "" Then
  63.         AR = Split(S, "\")
  64.         xPath = AR(0)
  65.         For i = 1 To UBound(AR) - 1
  66.             xPath = xPath & "\" & AR(i)
  67.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  68.         Next
  69.     End If
  70. End Sub
  71. Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  72.     Dim fs As Object, E As Range, C As Variant
  73.     Set fs = CreateObject("Scripting.FileSystemObject")
  74.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  75.     For Each E In Q.ResultRange.Rows
  76.         C = Application.Transpose(Application.Transpose(E.Value))
  77.         C = Join(C, vbTab)
  78.         fs.WriteLine C
  79.     Next
  80.     fs.Close
  81. End Sub
複製代碼
test2.zip (17.73 KB)

TOP

        靜思自在 : 道德是提昇自我的明燈，不該是呵斥別人的鞭子。
123456
返回列表 上一主題