12345678910
返回列表 上一主題 發帖

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
86# 跳轉到 »
發表於 2017-6-15 22:01 | 只看該作者
回復 85# GBKEE
不好意思，我執行後似乎會卡在圖中的迴圈，不知能否請您執行看看是否有一樣情形呢？

  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, aa 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 = "F:\財報資料"
  24.     IE_Application    '
  25.     Application.StatusBar = " "
  26.     For Each E In Rng
  27. MR:
  28.         With Sheets(1)
  29.             .Activate
  30.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  31.         End With
  32.         For Each X In Rng1
  33.             With IE
  34.                 .Document.getElementsByTagName("select")("Yy").Value = X
  35.                 'yy -> 年度,mm -> 月份, dd -> 日期
  36.                 .Document.getelementsbyname("stockNo")(0).Value = E
  37.                 '股票代碼  stockNo  '**大小寫要一致**
  38. '                .Document.getelementsbyname("query-button")(0).Click  '按下查詢
  39.                 For Each Ea In .Document.body.all.tags("a")
  40.                     If Ea.classname = "button search" Then
  41.                         Ea.Click: Exit For  '按下查詢
  42.                     End If
  43.                 Next
  44.                 Do While .Busy Or .readyState <> 4:    Loop
  45.                 On Error Resume Next
  46.                 If InStr(.Document.getElementsByTagName("TABLE")(3).outerHTML, "查無") Then GoTo Nn
  47.                 If .Document.getElementsByTagName("TABLE")(3).Rows.Length > 1 Then
  48.                     Ep .Document.getElementsByTagName("TABLE")(3).outerHTML
  49.                 Else
  50.                     GoTo Nn
  51.                 End If
  52. '                If InStr(Selection.Cells(3, 1), "查無") Then Selection.Delete Shift:=xlUp: GoTo Nn
  53.             End With
  54.         With Sheets(1)
  55.             aa = Selection.Range("a3")
  56. '            If aa = "" Then aa = Selection.Range("a1")    '會出錯才加入這段
  57.             If aa + 1911 <> X Then GoTo MR
  58.         End With
  59.         Next X
  60. Nn:
  61.         If Sheets(1).Range("a1") = "" Then GoTo KK
  62.         xFile = xPath & "\" & E & "\HPM.txt"
  63.         MkDir_Sub xFile
  64.         Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
  65.         ii = ii + 1
  66.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 匯入上市月成交 " & E & "共" & ii & " 文字檔"
  67. KK:
  68.     Next E
  69.     IE.Quit
  70.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  71.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  72. '    ThisWorkbook.Save
  73. End Sub
  74. Sub Ep(S As String)
  75.     Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
  76.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  77.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  78.     On Error GoTo ER
  79.     With D
  80.         .SetText S
  81.         .PutInClipboard
  82.         With Sheets(1)
  83.             With .Range("a" & .Rows.Count).End(xlUp)
  84.                 If .Row = 1 Then
  85.                     Set Rng = .Cells
  86.                 Else
  87.                     Set Rng = .Offset(1)
  88.                 End If
  89.                 Rng.Select
  90.                 .Parent.PasteSpecial Format:="Unicode 文字"
  91.                 Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
  92.                 With Sheets(1).Sort
  93.                     .SetRange Rng
  94.                     .Header = xlGuess
  95.                     .MatchCase = False
  96.                     .Orientation = xlTopToBottom
  97.                     .SortMethod = xlPinYin
  98.                     .Apply
  99.                 End With
  100.                 'Sort :資料排序
  101. '                Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  102.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  103.                 :=xlStroke, DataOption1:=xlSortNorma
  104. '                If .Row = 1 Then
  105. '                    .Range("A2").EntireRow.Delete
  106. '                Else
  107. '                    .Range("A2:A4").EntireRow.Delete
  108. '                End If
  109.             End With
  110.         End With
  111.     End With
  112.     Exit Sub
  113. ER:
  114.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
  115.     Resume
  116. End Sub
  117. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  118.     Dim fs As Object, E As Range, C As Variant, A As String, B As Integer, D As String
  119.     Set fs = CreateObject("Scripting.FileSystemObject")
  120.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  121.     A = Q.Cells(1)
  122.     B = Len(A)
  123.         If B >= 25 Then
  124.             D = Mid(A, 11, 4)
  125.         Else
  126.             D = Mid(A, 11, 2)
  127.         End If
  128.     Q.Cells(1) = Code & "-" & D & "" & " 月成交資料"   '加入股票代號
  129.     If Q.Cells(3, 1).Offset(1) = "" Then GoTo EE
  130.     Q.Range("a3", Q.Range("a3").End(xlDown)).Replace "年度", ""
  131.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).Offset(-1).EntireRow.Delete
  132.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  133. EE:
  134.     For Each E In Q.Rows
  135.         C = Application.Transpose(Application.Transpose(E.Value))
  136.         C = Join(C, vbTab)
  137.         fs.Write C
  138.     Next
  139.     fs.Close
  140. End Sub
  141. Sub MkDir_Sub(S As String)
  142.     Dim ar, i As Integer, xPath As String
  143.     If Dir(S) = "" Then
  144.         ar = Split(S, "\")
  145.         xPath = ar(0)
  146.         For i = 1 To UBound(ar) - 1
  147.             xPath = xPath & "\" & ar(i)
  148.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  149.         Next
  150.     End If
  151. End Sub
複製代碼
上市月成交資訊.zip (39.22 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兔年全勤獎章
85#
發表於 2017-6-15 15:10 | 只看該作者
本帖最後由 GBKEE 於 2017-6-15 15:14 編輯

  1. For Each X In Rng1
  2.             With IE
  3.                 .Document.getElementsByTagName("select")("Yy").Value = X
  4.                 'yy -> 年度,mm -> 月份, dd -> 日期
  5.                 .Document.getelementsbyname("stockNo")(0).Value = E
  6.                 '股票代碼  stockNo  '**大小寫要一致**
  7.               '  .Document.getelementsbyname("query-button")(0).Click  '按下查詢
  8.                 For Each Ea In .Document.body.all.tags("a")
  9.                     If Ea.classname = "button search" Then
  10.                         Ea.Click: Exit For  '按下查詢
  11.                     End If
  12.                 Next
  13.                 Do While .Busy Or .readyState <> 4:    Loop
  14.                 On Error Resume Next
複製代碼
回復 84# smart3135
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
84#
發表於 2017-6-14 16:07 | 只看該作者
回復 56# GBKEE
不好意思，由於今年證交所網址大改版，原本的抓資料程式碼都會出錯，有試著看網頁原始碼修改程式碼
無奈功力太淺還是沒辦法，不知道是否還有機會請版主指點一下究竟該如何修改呢？
上市年月成交資訊.zip (62.39 KB)
  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, aa 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 = "F:\財報資料"
  24.     IE_Application    '
  25.     Application.StatusBar = " "
  26.     For Each E In Rng
  27. MR:
  28.         With Sheets(1)
  29.             .Activate
  30.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  31.         End With
  32.         For Each X In Rng1
  33.             With IE
  34.                 .Document.getElementsByTagName("select")("query_year").Value = X
  35.                 .Document.getelementsbyname("CO_ID")(0).Value = E
  36.                 .Document.getelementsbyname("query-button")(0).Click  '按下查詢
  37.                 Do While .Busy Or .readyState <> 4:    Loop
  38.                 On Error Resume Next
  39.                 If InStr(.Document.getElementsByTagName("TABLE")(3).outerHTML, "查無") Then GoTo Nn
  40.                 If .Document.getElementsByTagName("TABLE")(3).Rows.Length > 1 Then
  41.                     Ep .Document.getElementsByTagName("TABLE")(3).outerHTML
  42.                 Else
  43.                     GoTo Nn
  44.                 End If
  45. '                If InStr(Selection.Cells(3, 1), "查無") Then Selection.Delete Shift:=xlUp: GoTo Nn
  46.             End With
  47.         With Sheets(1)
  48.             aa = Selection.Range("a3")
  49.             If aa = "" Then aa = Selection.Range("a1")    '會出錯才加入這段
  50.             If aa + 1911 <> X Then GoTo MR
  51.         End With
  52.         Next X
  53. Nn:
  54.         If Sheets(1).Range("a1") = "" Then GoTo KK
  55.         xFile = xPath & "\" & E & "\HPM.txt"
  56.         MkDir_Sub xFile
  57.         Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
  58.         ii = ii + 1
  59.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 匯入上市月成交 " & E & "共" & ii & " 文字檔"
  60. KK:
  61.     Next E
  62.     IE.Quit
  63.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  64.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  65. '    ThisWorkbook.Save
  66. End Sub
  67. Sub Ep(S As String)
  68.     Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
  69.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  70.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  71.     On Error GoTo ER
  72.     With D
  73.         .SetText S
  74.         .PutInClipboard
  75.         With Sheets(1)
  76.             With .Range("a" & .Rows.Count).End(xlUp)
  77.                 If .Row = 1 Then
  78.                     Set Rng = .Cells
  79.                 Else
  80.                     Set Rng = .Offset(1)
  81.                 End If
  82.                 Rng.Select
  83.                 .Parent.PasteSpecial Format:="Unicode 文字"
  84.                 Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
  85.                 With Sheets(1).Sort
  86.                     .SetRange Rng
  87.                     .Header = xlGuess
  88.                     .MatchCase = False
  89.                     .Orientation = xlTopToBottom
  90.                     .SortMethod = xlPinYin
  91.                     .Apply
  92.                 End With
  93.                 'Sort :資料排序
  94. '                Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  95.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  96.                 :=xlStroke, DataOption1:=xlSortNorma
  97. '                If .Row = 1 Then
  98. '                    .Range("A2").EntireRow.Delete
  99. '                Else
  100. '                    .Range("A2:A4").EntireRow.Delete
  101. '                End If
  102.             End With
  103.         End With
  104.     End With
  105.     Exit Sub
  106. ER:
  107.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
  108.     Resume
  109. End Sub
  110. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  111.     Dim fs As Object, E As Range, C As Variant, A As String, B As Integer, D As String
  112.     Set fs = CreateObject("Scripting.FileSystemObject")
  113.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  114.     A = Q.Cells(1)
  115.     B = Len(A)
  116.         If B >= 25 Then
  117.             D = Mid(A, 11, 4)
  118.         Else
  119.             D = Mid(A, 11, 2)
  120.         End If
  121.     Q.Cells(1) = Code & "-" & D & "" & " 月成交資料"   '加入股票代號
  122.     If Q.Cells(3, 1).Offset(1) = "" Then GoTo EE
  123.     Q.Range("a3", Q.Range("a3").End(xlDown)).Replace "年度", ""
  124.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).Offset(-1).EntireRow.Delete
  125.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  126. EE:
  127.     For Each E In Q.Rows
  128.         C = Application.Transpose(Application.Transpose(E.Value))
  129.         C = Join(C, vbTab)
  130.         fs.Write C
  131.     Next
  132.     fs.Close
  133. End Sub
  134. Sub MkDir_Sub(S As String)
  135.     Dim ar, i As Integer, xPath As String
  136.     If Dir(S) = "" Then
  137.         ar = Split(S, "\")
  138.         xPath = ar(0)
  139.         For i = 1 To UBound(ar) - 1
  140.             xPath = xPath & "\" & ar(i)
  141.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  142.         Next
  143.     End If
  144. End Sub
複製代碼

上市年月成交資訊.zip (62.39 KB)

TOP

smart3135

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

在IE8下可執行,請看看你的IE [網際網路選項]需修改什麼!!
GBKEE 發表於 2015-2-11 16:10

Hello版主，經確認之後應該是和我的系統問題有關係，因為今天重灌電腦後，再用原來的程式碼跑一次
就是最原始的那個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兔年全勤獎章
82#
發表於 2015-2-11 16:10 | 只看該作者
回復 81# smart3135

在IE8下可執行,請看看你的IE [網際網路選項]需修改什麼!!
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
81#
發表於 2015-2-11 08:32 | 只看該作者
本帖最後由 smart3135 於 2015-2-11 08:33 編輯
回復  smart3135
GBKEE 發表於 2015-2-10 17:29

版主您好，有試著套用您的程式碼，但在加入Refresh後會出現下圖錯誤


若是將Refresh註解跳過，是可以順利執行，不過有時候跑到一半的時候就不動了，似乎是在執行無限迴圈
必須要按ESC強制停止，再按偵錯就會跳到Do While .Busy Or .ReadyState <> 4:    Loop這段程式碼
應該就是這段程式碼在執行無限迴圈



上市年成交資訊.zip (27.04 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兔年全勤獎章
80#
發表於 2015-2-10 17:29 | 只看該作者
回復 79# smart3135
  1. For Each E In Rng
  2.         With IE
  3.             Do While .Busy Or .ReadyState <> 4:    Loop
  4.             .Document.getelementbyid("STK_NO").Value = E
  5.             .Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
  6.             Do While .Busy Or .ReadyState <> 4:    Loop
  7.             .Refresh  '網頁 需重新整理 ,才有資料下載
  8.             Do While .Busy Or .ReadyState <> 4:    Loop
  9.             Set a = .Document.getelementsbytagname("TABLE")
  10.             Do While a.Length <> 14:   Loop    '直到 a元素的子項目有14個
  11.             xFile = xPath & "\" & E & "\HPY.txt"
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
79#
發表於 2015-2-10 11:34 | 只看該作者
回復  smart3135
GBKEE 發表於 2014-5-26 17:13

GBKEE版主您好，去年有向您請教如何用迴圈抓取股市大量資料，幫助非常大，今年已經有新的年度資料，我想要抓取新的年度資料
但不知道為什麼去年度可以正常執行的VBA程式碼，到了今年卻會一直出錯，我嘗試新增、刪除、變更一些程式碼，但都無效
能不能請您再次幫忙看看程式碼有什麼問題嗎？感謝您！
上市年成交資訊.zip (22.07 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兔年全勤獎章
78#
發表於 2014-5-26 17:13 | 只看該作者
回復 74# smart3135
  1. Option Explicit
  2. Dim IE As Object, A As Integer
  3. Sub IE_Application()
  4.     Dim I As Integer
  5.     Set IE = CreateObject("InternetExplorer.Application")
  6.     With IE
  7.         .Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
  8.         .Visible = True   '不顯示ie
  9.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  10.         '讀取集保戶股權分散表查詢的資料日期總個數
  11.         A = .document.getelementsbytagname("select")("SCA_DATE").Length - 1
  12.   End With
  13. End Sub
  14. Sub 集保()
  15.     Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
  16.     Dim Ea As Variant, ii As Integer, F As String, H As String, J As Integer
  17.     Dim StockNo  As Object
  18.     T = Time
  19.     Application.DisplayStatusBar = True
  20.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  21.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  22.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  23.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  24.     xPath = "D:\財報資料"
  25.     IE_Application    '
  26.     Application.StatusBar = " "
  27.     For Each E In Rng
  28.             With Sheets(1)
  29.                 .Activate
  30.                 .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  31.             End With
  32.             For x = 0 To A
  33.                 With IE
  34.                     .document.getelementsbytagname("select")("SCA_DATE")(x).Selected = True
  35.                    '.document.getElementById("StockNo").Value = E  'getElementById於 2007有錯誤
  36.                     .document.ALL("StockNo").Value = E             'ALL 於2007可行
  37.                     .document.getelementsbytagname("INPUT")("sub").Click  '按下查詢
  38.                     Do While .Busy Or .readyState <> 4
  39.                         .document.Focus
  40.                         Application.SendKeys "~", True ' 按下確定鍵
  41.                     Loop
  42.                     Set StockNo = Nothing
  43.                     Do While StockNo Is Nothing
  44.                         Set StockNo = .document.getelementsbytagname("TABLE")
  45.                     Loop
  46.                     With StockNo
  47.                        If .Length <= 5 Then GoTo Nextx  '查無資料
  48.                         If x = 0 Then Sheets(1).Cells(1) = .Item(5).INNERTEXT
  49.                         Ep .Item(6).INNERTEXT
  50.                         Ep .Item(7).outerHTML
  51.                     End With
  52.                 End With
  53.             Next x
  54. Nextx:
  55.             If Sheets(1).UsedRange.Rows.Count > 1 Then
  56.                 xFile = xPath & "\" & E & "\SHD.txt"
  57.                 MkDir_Sub xFile
  58.                 Maketxt xFile, Sheets(1).UsedRange, E.Value
  59.                 ii = ii + 1
  60.                 Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
  61.             End If
  62.             Debug.Print IE.document.getelementsbytagname("TABLE").Length
  63.         Next E
  64.     IE.Quit
  65.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  66.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  67. '    ThisWorkbook.Save
  68. 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兔年全勤獎章
77#
發表於 2014-5-26 17:12 | 只看該作者
本帖最後由 GBKEE 於 2014-5-26 17:15 編輯

回復 75# smart3135
  1. Option Explicit
  2. Sub 集保完成()
  3.     Dim E As Range, X As Range, URL As String, xPath As String, xFile As String, rng As Range, rng1 As Range
  4.     Dim Msg As Boolean, I As Integer, t As Date, S As String, BB As String, CC As String, rng2 As Range
  5.     IE_Application  '更新集保戶股權分散表查詢的資料日期
  6.     t = Time
  7.     URL = "URL;http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE="
  8.     BB = "&SqlMethod=StockNo&StockNo="
  9.     CC = "&sub=%ACd%B8%DF"
  10.     xPath = "D:\財報資料"
  11.     With ThisWorkbook
  12.         With .Sheets(3)
  13.             Set rng = .Range("A1", .Range("A1").End(xlDown))
  14.             Set rng1 = .Range("B1", .Range("B1").End(xlDown))
  15.         End With
  16.         With .Sheets(1)      '活頁簿的第 1 張工作表
  17.             If .QueryTables.Count = 0 Then
  18.                 With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
  19.                     .Refresh BackgroundQuery:=False
  20.                 End With
  21.             End If
  22.             
  23.             For Each E In rng
  24.                 With ThisWorkbook
  25.                 .Sheets(2).Cells.Clear
  26.                 .Sheets(1).Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  27.             End With
  28.                 For Each X In rng1
  29.                     With .QueryTables(1)
  30.                         .Connection = URL & X & BB & E & CC
  31.                         .PreserveFormatting = True
  32.                         .BackgroundQuery = True
  33.                         .RefreshStyle = xlInsertDeleteCells
  34.                         .SaveData = True
  35.                         .AdjustColumnWidth = True
  36.                         .RefreshPeriod = 0
  37.                         .WebSelectionType = xlSpecifiedTables
  38.                         .WebFormatting = xlWebFormattingNone
  39.                         If X.Row = 1 Then
  40.                         .WebTables = "6,7,8"
  41.                         Else
  42.                             .WebTables = "7,8"
  43.                         End If
  44.                         On Error GoTo xlnext
  45.                         .WebPreFormattedTextToColumns = True
  46.                         .WebConsecutiveDelimitersAsOne = True
  47.                         .Refresh BackgroundQuery:=False
  48.                         If Sheets(2).Range("a1") = "" Then
  49.                             .ResultRange.Copy Sheets(2).Range("a" & Sheets(2).Rows.Count).End(xlUp)
  50.                         Else
  51.                             .ResultRange.Copy Sheets(2).Range("a" & Sheets(2).Rows.Count).End(xlUp).Offset(2, 0)
  52.                         End If
  53.                     End With
  54.                 Next
  55. xlnext:
  56.       
  57.                     xFile = xPath & "\" & E & "\SHD.txt"
  58.                     MkDir_Sub xFile       '10#的程式 'C槽下的季損益表資料夾不需先建立
  59.                     Maketxt xFile, Sheets(2).UsedRange
  60.                 I = I + 1
  61.                 Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & "  " & E & "匯入" & I & "個文字檔"
  62.                 Msg = False
  63.             Next E
  64.         End With
  65.     End With
  66.     MsgBox "共匯入 文字檔" & I & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  67. End Sub
  68. Sub Maketxt(xF As String, Q As Range)   '將匯入資料存入指定的txt
  69.     Dim fs As Object, E As Range, C As Variant
  70.     '*************************
  71.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete  '刪除空白列
  72.     '*************************
  73.     Set fs = CreateObject("Scripting.FileSystemObject")
  74.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  75.     For Each E In Q.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
  82. Private Sub IE_Application() '更新集保戶股權分散表查詢的資料日期
  83.     Dim IE As Object, A As Object, I As Integer
  84.     Set IE = CreateObject("InternetExplorer.Application")
  85.     With IE
  86.         .Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
  87.         .Visible = True
  88.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  89.         '讀取集保戶股權分散表查詢的資料日期
  90.         Set A = .document.getelementsbytagname("option")
  91.        For I = 0 To A.Length - 1
  92.         ThisWorkbook.Sheets(3).Cells(I + 1, "B") = A(I).INNERTEXT
  93.        Next
  94.        .Quit
  95.   End With
  96. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 滴水成河。粒米成蘿，勿輕己靈，勿以善小而不為。
12345678910
返回列表 上一主題