12345678910
返回列表 上一主題 發帖

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
31# 跳轉到 »
發表於 2014-4-26 19:13 | 只看該作者
回復 30# GBKEE
先感謝GBKEE版主一一耐心的回答，因為今晚還要上班，所以您在27#更新的程式碼，可能要等到明天才能try了！
至於電腦減肥部分
1將下面文字複製到記事本  存檔為附檔名 ".BAT",傳送到桌面上 ,不定時的清理垃圾檔案－這個BAT檔我一直都有在用，是否每次執行完VBA就要清一次呢？
2不定時的清空資源回收筒 －最近丟到資源回收筒的資料較多，有空會試一下清空會不會好一點
3 不定時清空IE的瀏覽記錄－平常都是用chorme流灠器為主，不過最近因為要EXCEL匯入WEB資料所以有比較常用，會清空再來試試
4 定時的清理磁碟－兩天前才剛將磁碟重組
5擴充記憶體－我的系統是WIN7 64位元+office 2007，記憶體是4G，不知道這樣有需要擴充嗎？

我有發現會跑那麼久是因為我給的區間越大，程式跑到越後面就越慢，例如我程式碼設定For E = 1101 to 9962，只執行一次，跑起來可能需要40分鐘
但我將程式碼設定For E = 1101 to 3000，For E = 3001 to 5000，For E = 5001 to 7000，For E = 7001 to 9962，共執行四次，合計起來的時間就不需要那麼久
E的區間設定越小，完成的時間就越短，這部分就不太理解為什麼會這樣了！

另外雖然您在27#的程式碼已更新，不過還是希望能了解一下我在28#向您提問的AR=Array(1202,1433,1502,1610.....................)這樣要把200個代碼全部輸入
會跳到第二行，然後就會出錯，不知道有沒有辦法解決這個問題呢？
不知道這個AR的Array區間有沒有辦法輸入200個引數以上呢？

TOP

GBKEE

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

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

回復 31# smart3135
這個BAT檔我一直都有在用，是否每次執行完VBA就要清一次呢？,你要跑這程式當然最好是的,檔案開開關關會製造一些暫存檔,就需要清一下
WIN7 64位元+office 2007，記憶體是4G，是不需擴充了,另就就開機時系統要載太入的常駐應用程式.佔據太多的記憶體.這也是主因之ㄧ.
XP,32位元, 1GB, 2003版, 27#程式 For 1101 To 5000的迴圈 ,減肥後7分鐘內搞定.
E的區間設定越小，完成的時間就越短，這部分就不太理解為什麼會這樣了,這是想當然的
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ar
  4.     Ar = Array(56, 78, _
  5.          9, 10, 12 _
  6.        , 888, 999, _
  7.        56789)
  8. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
33#
發表於 2014-4-26 21:30 | 只看該作者
回復 32# GBKEE
哇 1101到5000跑完只要七分鐘 好威！
我之前也有試過接下引號跳下一行，但一直失敗，原來要跳下一行前接的下引號後面要有空格，又學到一招了，再次感謝您的指導！

TOP

smart3135

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

GBKEE

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

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

回復 34# smart3135
  1. Option Explicit
  2. Private Sub Test()
  3.     Dim fs As Object, E As Range, C As Variant
  4.     Set fs = CreateObject("Scripting.FileSystemObject")
  5.     Set fs = fs.CreateTextFile("D:\財報資料\1101\Test.TXT", True)
  6.     '創見一個檔案,如檔案存在可覆蓋掉
  7.     '文字檔的寫入是
  8.     For Each E In Sheets(1).UsedRange.Columns
  9.         C = E.Value  '-> 陣列(1 To 列數,1 To 欗數)的二維陣列
  10.         C = Application.Transpose(E.Value) '因為第二維只有一欄,轉置一次可變為一維陣列
  11.        '如E In UsedRange.rows
  12.        'C = E.Value  '-> 陣列(1 To 列數,1 To 欗數)的二維陣列
  13.        'C = Application.Transpose(Application.Transpose(E.Value)) '第二維不只一欄,所以轉置二次才可變為一維陣列
  14.         C = Join(C, vbTab)
  15.         'Join 函數 傳回一個字串，該字串是透過連結某個陣列中的多個子字串而建立的。
  16.         'Join 函數 使用的陣列必須是一維陣列
  17.         fs.WriteLine C
  18.     Next
  19.     fs.Close
  20. End Sub
複製代碼



詳看註解可明瞭.

  2. Option Explicit
  3. Sub 抓季月營收資料()
  4.     Dim E As Integer, URL As String, xPath As String, xFile As String
  5.     Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
  6.     Dim AR()
  7.     t = Time
  8.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
  9.     xPath = "D:\財報資料"
  10.     Application.DisplayStatusBar = True
  11.     With ThisWorkbook
  12.         '兩者取一即可 (選擇儲存格較方便)
  13.         '***'不需要的股票如4203天仁(後抓取)是錯誤的股票號碼 置入-> Ar陣列
  14.    ' AR = Array(1202, 1420, 1433, 1502, 1518, 1610, 1716, 2346, 2372, 2391, 2513, 2526, 2541, 2802, 2803, 2804, 2806, _
  15.             2813, 2814, 2815, 2817, 2818, 2819, 2821, 2826, 2830, 2839, 2840, 2843, 2844, 2848, 2907, 2909, 4101, 4112, _
  16.             4175, 4201, 4203, 4204, 4301, 4302, 4405, 4407, 4409, 4410, 4411, 4412, 4504, 4505, 4507, 4508, 4509, 4512, _
  17.             4514, 4516, 4517, 4519, 4520, 4521, 4524, 4525, 4531, 4603, 4604, 4605, 4606, 4607, 4608, 4701, 4704, 4705, _
  18.             4708, 4709, 4710, 4713, 4715, 4718, 4901, 4902, 5001, 5003, 5004, 5005, 5012, 5101, 5311, 5319, 5320, 5322, _
  19.             5323, 5327, 5330, 5331, 5334, 5335, 5337, 5341, 5342, 5354, 5357, 5358, 5359, 5360, 5361, 5362, 5363, 5366, _
  20.             5368, 5369, 5374, 5377, 5379, 5380, 5382, 5389, 5391, 5393, 5394, 5396, 5397, 5399, 5404, 5405, 5408, 5409, _
  21.             5411, 5412, 5415, 5416, 5417, 5418, 5419, 5420, 5421, 5422, 5423, 5424, 5427, 5428, 5430, 5431, 5433, 5435, _
  22.             5440, 5444, 5445, 5446, 5447, 5449, 5453, 5456, 5458, 5459, 5461, 5462, 5463, 5470, 5472, 5476, 5477, 5482, _
  23.             5485, 5486, 5495, 5496, 5499, 5509, 5517, 5527, 5606, 5705, 5804, 5805, 5806, 5807, 5809, 5812, 5814, 5815, _
  24.             5854, 6003, 6006, 6019, 6102, 6106, 6401, 6501, 8001, 8003, 8903, 8904, 8912, 8914, 8915, 8918, 8920, 8922, 8939, 9105, 9909)
  25.             
  26.         '***A欄中不需要的股票 如4203天仁(後抓取)號碼的儲存格  置入-> Ar陣列
  27.         Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
  28.         If Rng Is Nothing Then
  29.             AR = Array()
  30.         ElseIf Rng.Count = 1 Then
  31.             AR = Array(Rng.Value)
  32.         Else
  33.             AR = Application.Transpose(Rng.Value)
  34.             
  35.             '先前出錯是這裡寫錯 AR = Application.Transpose(Application.Transpose(Rng.Value))
  36.             'Rng.Value=>單欄二維陣列
  37.         End If
  38.         '***************************************************
  39.         .Sheets(2).UsedRange.Offset(, 1).Clear
  40.         Application.ScreenUpdating = False
  41.         Application.StatusBar = " "
  42.         With .Sheets(1)      '活頁簿的第 1 張工作表
  43.             If .QueryTables.Count = 0 Then
  44.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  45.                     .Refresh BackgroundQuery:=False
  46.                 End With
  47.             End If
  48.             .Rows(1).Delete
  49.             .Columns(1).Delete
  50.             For E = 1101 To 5000
  51.                 If UBound(Filter(AR, E)) > -1 Then GoTo xLnext
  52.                 'Filter(AR, E)函數 等同使用Find方法 如 Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
  53.                 With .QueryTables(1)
  54.                     .Connection = URL & E
  55.                     .PreserveFormatting = True
  56.                     .BackgroundQuery = True
  57.                     .RefreshStyle = xlInsertDeleteCells
  58.                     .SaveData = True
  59.                     .AdjustColumnWidth = True
  60.                     .RefreshPeriod = 0
  61.                     .WebSelectionType = xlSpecifiedTables
  62.                     .WebFormatting = xlWebFormattingNone
  63.                     .WebTables = "3"
  64.                     .WebPreFormattedTextToColumns = True
  65.                     .WebConsecutiveDelimitersAsOne = True
  66.                     .Refresh BackgroundQuery:=False
  67.                     If InStr(.ResultRange(2, 1), "查無") Then      '查無這檔股票
  68.                         Mark_Code E                                '查無的股票 放置A攔
  69.                         GoTo xLnext
  70.                     End If
  71.                     S1 = .ResultRange(1)                '匯入資料的第1個儲存格
  72.                     S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
  73.                 End With
  74.                
  75.                 With ThisWorkbook.Sheets(2).Range("B:B")
  76.                     Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
  77.                     If Rng Is Nothing Then
  78.                         i = i + 1
  79.                         .Range("A" & i) = S1  '股票名稱代碼
  80.                     Else
  81.                        Mark_Code E '重複的股票 放置A攔
  82.                         S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
  83.                         S2 = Mid(S2, 1, Len(S2) - 1)    '舊的股票[代碼]
  84.                         xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
  85.                         If Dir(xFile) <> "" Then
  86.                             ii = ii - 1
  87.                             Kill xFile
  88.                             xFile = xPath & "\" & S2
  89.                             If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
  90.                         End If
  91.                     End If
  92.                 End With
  93.                 ii = ii + 1
  94.                 xFile = xPath & "\" & E & "\REVENUE.txt"
  95.                 MkDir_Sub xFile
  96.                 Maketxt xFile, .QueryTables(1)
  97. xLnext:
  98.                 S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
  99.                 If Val(S1) < 0 Then S1 = " 查無"
  100.                 Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入 " & ii & " 文字檔,  讀取 " & S1 & " 中..."
  101.             Next
  102.         End With
  103.     End With
  104.     Application.ScreenUpdating = True
  105.     Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入 " & ii & " 文字檔,  讀取完畢 !! "
  106.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.text(Time - t, ["MM分SS秒"])
  107.     ThisWorkbook.Save
  108. End Sub
複製代碼
  1. Private Sub Mark_Code(S As Integer)
  2.     With ThisWorkbook.Sheets(2).Range("A:A") '重複的股票 放置A攔
  3.         .Cells(Application.Count(.Cells) + 1, "A") = S
  4.         '股票代號放置 A攔最後一個儲存格
  5.         '執行一次後,下次再執行 [抓季月營收資料]程式時,For 迴圈中可踢除這股票代號
  6.     End With
  7. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

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

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
38#
發表於 2014-4-28 11:23 | 只看該作者
回復 37# smart3135
先回覆上櫃月成交資訊,事情忙完再繼續回覆你
  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
  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 = "D:\財報資料"
  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 & "\上櫃月成交.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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
40#
發表於 2014-4-28 17:48 | 只看該作者
回復 39# smart3135
跑一個文字檔的時間大約要4-5秒，確定有清理系統了，不過還是非常慢 ?
可能是越老的版本速度越快,試試2003版看看
另外有辦法像之前將匯入資料顯示在EXCEL以便逐行執行時可以看出EXCEL如何變化，如此速度更慢了.

  1. Option Explicit
  2. Sub 集保戶股權_WEB_製圖()
  3.     Dim WB As Workbook, Rng As Range
  4.     Dim Ar(), A, i As Integer, strDate As String, stkno As String, Qur As String
  5.     With CreateObject("InternetExplorer.Application")
  6.         .Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
  7.         Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
  8.         Set A = .document.All.tags("option") '資料日期的內容
  9.         ReDim Ar(A.Length - 1)
  10.         For i = 0 To A.Length - 1
  11.             Ar(i) = A(i).innerHTML
  12.         Next
  13.         .Quit
  14.     End With
  15.     Set WB = Workbooks.Add
  16.     With WB
  17.         .Sheets(1).Name = "圖表"
  18.         .Sheets(2).Name = "資料庫"
  19.     End With
  20.     stkno = InputBox("輸入股票代號", "股票代號", 2317)    '
  21.     If stkno = "" Or Len(stkno) <> 4 Or Val(stkno) = 0 Then MsgBox "股票代號"
  22.     For i = 0 To UBound(Ar)
  23.         strDate = Ar(i)  '導入月份
  24.         Qur = "http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=" & strDate & "&SqlMethod=StockNo&StockNo=" & stkno & "&StockName=&sub=%ACd%B8%DF"          '
  25.         With WB.Sheets(3)
  26.             If .QueryTables.Count = 0 Then
  27.                 .QueryTables.Add "URL;" & Qur, .[A1]
  28.             Else
  29.                 .QueryTables(1).Connection = "URL;" & Qur
  30.             End If
  31.             With .QueryTables(1)
  32.                 .WebSelectionType = xlSpecifiedTables
  33.                 .WebFormatting = xlWebFormattingNone
  34.                 .WebTables = "6,7,8"
  35.                 .WebPreFormattedTextToColumns = True
  36.                 .WebConsecutiveDelimitersAsOne = True
  37.                 .WebSingleBlockTextImport = False
  38.                 .WebDisableDateRecognition = False
  39.                 .WebDisableRedirections = False
  40.                 .Refresh BackgroundQuery:=False
  41.                 If Application.Count(.ResultRange) = 0 Then
  42.                     MsgBox "股票代號 " & stkno & " 錯誤"
  43.                     WB.Close , False
  44.                     Exit Sub
  45.                 End If
  46.                 If i = 0 Then WB.Sheets(2).Cells(2, i + 1).Resize(15) = .ResultRange.Range("B6").Resize(15).Value
  47.                 WB.Sheets(2).Cells(1, i + 2) = Mid(.ResultRange.Range("A3"), 6)
  48.                 WB.Sheets(2).Cells(2, i + 2).Resize(15) = .ResultRange.Range("E6").Resize(15).Value
  49.             End With
  50.         End With
  51.     Next
  52.     With WB
  53.       Set Rng = .Sheets(2).UsedRange
  54.        With .Sheets(1)
  55.             With .ChartObjects.Add(.[B3].Left, .[B3].Top, .[B3].Resize(, 15).Width, .[B3].Resize(25).Height).Chart
  56.                 .ChartType = xlLineMarkers
  57.                 .SetSourceData Rng, xlRows
  58.                 .SeriesCollection(13).AxisGroup = 2
  59.                 .HasTitle = True
  60.                 .ChartTitle.Characters.Text = WB.Sheets(3).[A1]
  61.                 .PlotArea.Interior.ColorIndex = 23
  62.             End With
  63.         End With
  64.         .Activate
  65.     End With
  66. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 口說好話、心想好意、身行好事。
12345678910
返回列表 上一主題