1234
返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11# 跳轉到 »
發表於 2014-4-25 18:55 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-26 15:42 編輯

回復 26# smart3135
大約要耗時40分鐘以上,是有點久,電腦要減肥了
建議減肥方式如下
1將下面文字複製到記事本  存檔為附檔名 ".BAT",傳送到桌面上 ,不定時的清理垃圾檔案
2不定時的清空資源回收筒
3 不定時清空IE的瀏覽記錄
4 定時的清理磁碟
5擴充記憶體

4203天仁(後抓取)是錯誤的股票號碼,這些股票名稱(代號) 連續一起輸入在Sheets(2)的A欄
  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(4203) '輸入 4203天仁(後抓取)是錯誤的股票號碼
  8.     URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
  9.     xPath = "D:\財報資料"
  10.     With ThisWorkbook
  11.         .Sheets(2).UsedRange.Offset(, 1).Clear
  12.         '4203天仁(後抓取)是錯誤的股票號碼 這些 股票名稱(代號) 連續一起輸入在Sheets(2)的A欄
  13.         Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
  14.         If Rng Is Nothing Then
  15.             AR = Array()
  16.         ElseIf Rng.Count = 1 Then
  17.             AR = Array(Rng.Value)
  18.         Else
  19.             AR = Application.Transpose(Application.Transpose(Rng))
  20.         End If        '***************************************************
  21.         Application.ScreenUpdating = False
  22.         Application.StatusBar = " "
  23.         With .Sheets(1)      '活頁簿的第 1 張工作表
  24.             If .QueryTables.Count = 0 Then
  25.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  26.                     .Refresh BackgroundQuery:=False
  27.                 End With
  28.             End If
  29.                 .Rows(1).Delete
  30.                 .Columns(1).Delete
  31.             For E = 1101 To 5000
  32.                 With .QueryTables(1)
  33.                     .Connection = URL & E
  34.                     .PreserveFormatting = True
  35.                     .BackgroundQuery = True
  36.                     .RefreshStyle = xlInsertDeleteCells
  37.                     .SaveData = True
  38.                     .AdjustColumnWidth = True
  39.                     .RefreshPeriod = 0
  40.                     .WebSelectionType = xlSpecifiedTables
  41.                     .WebFormatting = xlWebFormattingNone
  42.                     .WebTables = "3"
  43.                     .WebPreFormattedTextToColumns = True
  44.                     .WebConsecutiveDelimitersAsOne = True
  45.                     .Refresh BackgroundQuery:=False
  46.                     If .ResultRange(1) < 0 Or InStr(.ResultRange(2, 1), "查無") Then GoTo xLnext
  47.                     '匯入資料的 A1 < 0  OR  匯入資料的 A2 "查無"
  48.                     S1 = .ResultRange(1)
  49.                     S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
  50.                 End With
  51.                 With ThisWorkbook.Sheets(2).Range("B:B")
  52.                     Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
  53.                     If Rng Is Nothing Then
  54.                         i = i + 1
  55.                         .Range("A" & i) = S1  '股票名稱代碼
  56.                     Else
  57.                         Rng.Cells(1, 2) = S1   '重複的股票
  58.                         If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then
  59.                         'Filter(AR, E) > -1   '比對到如4203天仁(後抓取)是錯誤
  60.                             Rng.Cells(1, 2) = Rng.Cells(1, 2) & "***" '後抓取是錯誤
  61.                             GoTo xLnext:
  62.                         End If
  63.                         S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
  64.                         S2 = Mid(S2, 1, Len(S2) - 1)    '舊的股票[代碼]
  65.                         xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
  66.                         If Dir(xFile) <> "" Then
  67.                             ii = ii - 1
  68.                             Kill xFile
  69.                             xFile = xPath & "\" & S2
  70.                             If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
  71.                         End If
  72.                     End If
  73.                 End With
  74.                 ii = ii + 1
  75.                 xFile = xPath & "\" & E & "\REVENUE.txt"
  76.                 MkDir_Sub xFile
  77.                 Maketxt xFile, .QueryTables(1)
  78. xLnext:
  79.                 S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
  80.                 If Val(S1) < 0 Then S1 = " 查無"
  81.                 Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & "  " & E & S1
  82.             Next
  83.         End With
  84.     End With
  85.     Application.ScreenUpdating = True
  86.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " Ok "
  87.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  88. End Sub
  89. Private Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  90.     Dim fs As Object, E As Range, C As Variant
  91.     Set fs = CreateObject("Scripting.FileSystemObject")
  92.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  93.     For Each E In Q.ResultRange.Rows
  94.         C = Application.Transpose(Application.Transpose(E.Value))
  95.         C = Join(C, vbTab)
  96.         fs.WriteLine C
  97.     Next
  98.     fs.Close
  99. End Sub
複製代碼

EX.JPG (136.56 KB)

EX.JPG

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 2014-4-26 15:45 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-26 15:52 編輯

回復 29# smart3135
1233天仁(先抓取)是正確的，4203天仁(後抓取)是錯誤的問題
這一些錯誤股票名稱(代號) 天仁(4203) 連續一起輸入在Sheets(2)的A欄,後程式可解決.

28# 的所有問題.27#程式碼已更新了,可再看一次,減肥有試一下嗎?

試試看
  1. Sub Ex()
  2.     Dim E As Integer
  3.     For E = 500 To 5000
  4.         Select Case E
  5.             Case 500 To 1000
  6.                 GoTo xNext
  7.             Case 1500 To 2000
  8.                 GoTo xNext
  9.             Case 2500 To 3000
  10.                 GoTo xNext
  11.         End Select
  12.         MsgBox E
  13. xNext:
  14.     Next
  15. End Sub
  16. Sub Ex1()
  17.     Dim E As Integer
  18.     For E = 500 To 5000
  19.         If E >= 500 And E <= 1000 Or E >= 1500 And E <= 2000 Or E >= 2500 And E <= 3000 Then
  20.                 GoTo xNext
  21.         End If
  22.         MsgBox E
  23. xNext:
  24.     Next
  25. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

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-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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 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

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-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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
16#
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
17#
發表於 2014-4-30 10:27 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-30 10:30 編輯

回復 42# smart3135
WEB 查詢請 版上有許多討論 可搜尋 http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php  這字串
上市與 上櫃 網頁的建置不同
  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.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.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.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"
  16.     t = Time
  17.     Application.DisplayStatusBar = True
  18.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  19.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  20.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  21.     '你已將上市的股票代號,在Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  22.     xPath = "D:\財報資料"
  23.     IE_Application    '
  24.     Application.StatusBar = " "
  25.     Sheets(1).Activate
  26.     For Each E In Rng
  27.         With IE
  28.             Do While .Busy Or .ReadyState <> 4:    Loop
  29.             Set A = .Document.getelementbyid("STK_NO")
  30.             A.Value = E
  31.              .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
  32.             Do While .Busy Or .ReadyState <> 4:    Loop
  33.             Set A = .Document.getelementsbytagname("TABLE")
  34.             xFile = xPath & "\" & E & "\HPM.txt"
  35.             MkDir_Sub xFile
  36.              With Sheets(1)
  37.                 .Cells.Clear
  38.                 For i = 1 To A(7).Rows.Length - 1
  39.                     For C = 0 To A(7).Rows(i).Cells.Length - 1
  40.                     .Cells(i, C + 1) = A(7).Rows(i).Cells(C).innertext
  41.                     Next
  42.                 Next
  43.                 .UsedRange.Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=True  '排序:xlDescending ( 由大至小 )
  44.                 Maketxt xFile, .UsedRange
  45.             End With
  46.             ii = ii + 1
  47.         End With
  48.         Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔"
  49.     Next
  50.     IE.Quit
  51.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔,  讀取完畢 !! "
  52.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  53.     ThisWorkbook.Save
  54. End Sub
  55. Sub Maketxt(xF As String, Q As Range)   '***   Q As Range  ****
  56.     Dim fs As Object, E As Range, C As Variant
  57.     Set fs = CreateObject("Scripting.FileSystemObject")
  58.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  59.     For Each E In Q.Rows   '修改這  Q.ResultRange.Rows
  60.     C = Application.Transpose(Application.Transpose(E.Value))
  61.         C = Join(C, vbTab)
  62.         fs.WriteLine C
  63.     Next
  64.     fs.Close
  65. End Sub
  66. Sub MkDir_Sub(S As String)
  67.     Dim AR, i As Integer, xPath As String
  68.     If Dir(S) = "" Then
  69.         AR = Split(S, "\")
  70.         xPath = AR(0)
  71.         For i = 1 To UBound(AR) - 1
  72.             xPath = xPath & "\" & AR(i)
  73.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  74.         Next
  75.     End If
  76. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
18#
發表於 2014-5-4 15:51 | 顯示全部帖子
回復 46# smart3135
  1. For Each E In Rng
  2.         For Each X In Rng1
  3.             With IE
  4.          'http://forum.twbts.com/viewthread.php?tid=8111  chrom 中可查看元素的結構
  5.          '<select name="yy" class="input-select ui-corner-all" id="y_date1" onchange="query()">
  6.          '<option value="1996">85</option><option value="1997">86</option><option value="1998">87</option>         
  7.                 Set B = .document.getelementsbytagname("select")("YY")
  8.                 B.Value = X
  9.                 Set A = .document.getelementbyid("input_stock_code")
  10.                 A.Value = E
  11.    
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
19#
發表於 2014-5-7 17:04 | 顯示全部帖子
回復 48# 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/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 Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
  13.     Dim Ea As Variant, ar(), ii As Integer
  14.     T = Time
  15.     Application.DisplayStatusBar = True
  16.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  17.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  18.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  19.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  20.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  21.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  22.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  23.     xPath = "G:\財報資料"
  24.     IE_Application    '
  25.     Application.StatusBar = " "
  26.     For Each E In Rng
  27.         Sheets(1).UsedRange.Clear  '下載資料置於此工作表,變換股票時:清空
  28.         For Each X In Rng1
  29.             With IE
  30.                 .document.getElementsByTagName("select")("yy").Value = X
  31.                  With .document.getelementbyid("input_stock_code")
  32.                     .Value = E
  33.                     .ParentNode.submit
  34.                 End With
  35.                 Do While .Busy Or .readyState <> 4:    Loop
  36.                 If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
  37.                     ar = Array(0, 2)
  38.                 Else
  39.                     ar = Array(2)
  40.                 End If
  41.                 For Each Ea In ar
  42.                     Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
  43.                 Next
  44.             ii = ii + 1
  45.             End With
  46.         Next X
  47.         xFile = xPath & "\" & E & "\HPM.txt"
  48.         MkDir_Sub xFile
  49.         Maketxt xFile, Sheets(1).UsedRange
  50.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  51.     Next E
  52.     IE.Quit
  53.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔,  讀取完畢 !! "
  54.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  55.     ThisWorkbook.Save
  56. End Sub
  57. Sub Ep(S As String)
  58.     Dim D As New DataObject, E As Shape, FormDLL As String
  59.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  60.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  61.     On Error GoTo ER
  62.     With D
  63.         .SetText S
  64.         .PutInClipboard
  65.         With Sheets(1)
  66.             .Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
  67.             .PasteSpecial Format:="Unicode 文字"
  68.         End With
  69.     End With
  70.     Exit Sub
  71. ER:
  72.     FormDLL = "FM20.DLL"
  73.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  74.     Resume
  75. End Sub
  76. Sub MkDir_Sub(S As String)
  77.     Dim ar, i As Integer, xPath As String
  78.     If Dir(S) = "" Then
  79.         ar = Split(S, "\")
  80.         xPath = ar(0)
  81.         For i = 1 To UBound(ar) - 1
  82.             xPath = xPath & "\" & ar(i)
  83.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  84.         Next
  85.     End If
  86. End Sub
  87. Sub Maketxt(xF As String, Q As Range)    '將匯入資料存入指定的txt
  88.     Dim fs As Object, E As Range, C As Variant
  89.     Q.Range("C1") = ""
  90.     Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
  91.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  92.     Set fs = CreateObject("Scripting.FileSystemObject")
  93.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  94.     For Each E In Q.Rows
  95.         C = Application.Transpose(Application.Transpose(E.Value))
  96.         C = Join(C, vbTab)
  97.         fs.WriteLine C
  98.     Next
  99.     fs.Close
  100. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
20#
發表於 2014-5-15 16:21 | 顯示全部帖子
回復 50# smart3135


   
但在跑到 .ParentNode.submit會出現沒有使用權限，因為不懂這段程式碼的意思，能請您再幫忙一下嗎？
希望結果為
103年4月
103年3月
103年2月
103年1月
上市,上櫃的網頁建置不一樣
試試看
  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.twse.com.tw/ch/trading/exchange/FMSRFK/FMSRFKMAIN.php"
  7.         .Visible = True   '不顯示ie
  8.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  9.   End With
  10. End Sub
  11. Sub 上市月成交資訊()
  12.     Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
  13.     Dim Ea As Variant, ar(), ii As Integer
  14.     T = Time
  15.     Application.DisplayStatusBar = True
  16.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  17.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  18.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  19.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  20.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  21.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  22.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  23.     xPath = "D:\財報資料"
  24.     IE_Application    '
  25.     Application.StatusBar = " "
  26.     For Each E In Rng
  27.         With Sheets(1)
  28.             .Activate
  29.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  30.         End With
  31.         For Each X In Rng1
  32.             With IE
  33.                 .Document.getElementsByTagName("select")("myear").Value = X
  34.                  With .Document.getelementbyid("STK_NO")
  35.                     .Value = E
  36.                     .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
  37.                 End With
  38.                 Do While .Busy Or .readyState <> 4:    Loop
  39.                 Ep .Document.getElementsByTagName("TABLE")(7).outerHTML
  40.             End With
  41.         Next X
  42.         xFile = xPath & "\" & E & "\HPM.txt"
  43.         MkDir_Sub xFile
  44.         Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
  45.         ii = ii + 1
  46.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  47.     Next E
  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 Ep(S As String)
  54.     Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
  55.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  56.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  57.     On Error GoTo ER
  58.     With D
  59.         .SetText S
  60.         .PutInClipboard
  61.         With Sheets(1)
  62.             With .Range("a" & .Rows.Count).End(xlUp)
  63.                 If .Row = 1 Then
  64.                     Set Rng = .Cells
  65.                 Else
  66.                     Set Rng = .Offset(1)
  67.                 End If
  68.                 Rng.Select
  69.                 .Parent.PasteSpecial Format:="Unicode 文字"
  70.                 Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
  71.                 'Sort :資料排序
  72.                 Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  73.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  74.                 :=xlStroke, DataOption1:=xlSortNorma
  75.                 If .Row = 1 Then
  76.                     .Range("A2").EntireRow.Delete
  77.                 Else
  78.                     .Range("A2:A4").EntireRow.Delete
  79.                 End If
  80.             End With
  81.         End With
  82.     End With
  83.     Exit Sub
  84. ER:
  85.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
  86.     Resume
  87. End Sub
  88. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  89.     Dim fs As Object, E As Range, C As Variant
  90.     Set fs = CreateObject("Scripting.FileSystemObject")
  91.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  92.     Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號
  93.     For Each E In Q.Rows
  94.         C = Application.Transpose(Application.Transpose(E.Value))
  95.         C = Join(C, vbTab)
  96.         fs.WriteLine C
  97.     Next
  98.     fs.Close
  99. End Sub
  100. 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 小事不做、大事難成。
1234
返回列表 上一主題