1234
返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
21# 跳轉到 »
發表於 2014-5-16 15:57 | 顯示全部帖子
回復 52# smart3135
Q.Cells(1) 有不可見字元如圖,會造成程式碼的錯誤,所以變通一下
  1. Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天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兔年全勤獎章
22#
發表於 2014-5-17 17:29 | 顯示全部帖子
回復 55# smart3135


   
加了a=Q.Cells(1)有什麼不同呢?雖然執行時不會出錯，不過結果還是沒變，

加了a=Q.Cells(1),只是為了顯示於圖示:區域變數視窗中的不可見字元
  1. Sub 上市月成交資訊()
  2.     Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
  3.     Dim Ea As Variant, ar(), ii As Integer
  4.     T = Time
  5.     Application.DisplayStatusBar = True
  6.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  7.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  8.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  9.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  10.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  11.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  12.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  13.     xPath = "D:\財報資料"
  14.     IE_Application    '
  15.     Application.StatusBar = " "
  16.     For Each E In Rng
  17.         With Sheets(1)
  18.             .Activate
  19.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  20.         End With
  21.         For Each X In Rng1
  22.             With IE
  23.                 .Document.getElementsByTagName("select")("myear").Value = X
  24.                  With .Document.getelementbyid("STK_NO")
  25.                     .Value = E
  26.                     .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
  27.                 End With
  28.                 Do While .Busy Or .readyState <> 4:    Loop
  29.                 If .Document.getElementsByTagName("TABLE")(7).Rows.Length > 1 Then
  30.                     Ep .Document.getElementsByTagName("TABLE")(7).outerHTML
  31.                 Else
  32.                     GoTo Nn
  33.                 End If
  34.             End With
  35.         Next X
  36. Nn:
  37.         xFile = xPath & "\" & E & "\HPM.txt"
  38.         MkDir_Sub xFile
  39.         Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
  40.         ii = ii + 1
  41.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  42.     Next E
  43.     IE.Quit
  44.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔,  讀取完畢 !! "
  45.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  46. '    ThisWorkbook.Save
  47. End Sub
複製代碼
  1. Option Explicit
  2. Dim IE As Object
  3. Sub IE_Application()
  4.     If Not IE Is Nothing Then IE.Quit  '當查到上櫃的年份就會出現查無,此IE無法再度查詢,關閉它
  5.     Set IE = CreateObject("InternetExplorer.Application")
  6.     With IE
  7.         .Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
  8.         .Visible = True   '不顯示ie
  9.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  10.     End With
  11. End Sub
  12. Sub 上櫃月成交資訊()
  13.     Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
  14.     Dim Ea As Variant, AR(), ii As Integer, Msg As Boolean
  15.     T = Time
  16.     Application.DisplayStatusBar = True
  17.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  18.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  19.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  20.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  21.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  22.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  23.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  24.     xPath = "D:\財報資料"
  25.     Application.StatusBar = " "
  26.     For Each E In Rng
  27.         If Msg = False Then IE_Application   '當查到上櫃的年份就會出現查無,重開IE
  28.         Sheets(1).UsedRange.Clear            '下載資料置於此工作表,變換股票時:清空
  29.         For Each X In Rng1
  30.             With IE
  31.                 .document.getElementsByTagName("select")("yy").Value = X
  32.                 Do While .Busy Or .readyState <> 4:    Loop
  33.                  With .document.getelementbyid("input_stock_code")
  34.                     .Value = E
  35.                     .ParentNode.submit
  36.                 End With
  37.                 Do While .Busy Or .readyState <> 4:    Loop
  38.                 If InStr(.document.getElementsByTagName("TABLE")(0).innerHTML, "查無該筆資料") = 0 Then
  39.                     Msg = True
  40.                     If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
  41.                         AR = Array(0, 2)
  42.                     Else
  43.                         AR = Array(2)
  44.                     End If
  45.                     For Each Ea In AR
  46.                         Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
  47.                     Next
  48.                 Else
  49.                     Msg = False          '上櫃的年份就會出現查無
  50.                     GoTo NN
  51.                 End If
  52.             ii = ii + 1
  53.             End With
  54.         Next X
  55. NN:
  56.         xFile = xPath & "\" & E & "\HPM.txt"
  57.         MkDir_Sub xFile
  58.         Maketxt xFile, Sheets(1).UsedRange
  59.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii / 3 & " 文字檔"
  60.     Next E
  61.     IE.Quit
  62.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii / 3 & " 文字檔,  讀取完畢 !! "
  63.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  64. End Sub
  65. Sub Maketxt(xF As String, Q As Range)    '將匯入資料存入指定的txt
  66.     Dim fs As Object, E As Range, C As Variant
  67.     Q.Range("C1") = ""
  68.     Q.Range("A1") = Q.Range("B1") & " " & "月成交資料"
  69.     Q.Range("B1") = ""
  70.     Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
  71.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  72.     Q.Rows(3).Delete     '上櫃月成交資料當月還未結束時就會有資料了,所以要將還沒結束的月份刪除
  73.     '是Q.Rows(3)不 Rows(4)
  74.     Set fs = CreateObject("Scripting.FileSystemObject")
  75.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  76.     For Each E In Q.Rows
  77.         C = Application.Transpose(Application.Transpose(E.Value))
  78.         C = Join(C, vbTab)
  79.         fs.WriteLine C
  80.     Next
  81.     fs.Close
  82. 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兔年全勤獎章
23#
發表於 2014-5-19 16:18 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-5-20 16:04 編輯

回復 59# 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
  17.     T = Time
  18.     Application.DisplayStatusBar = True
  19.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  20.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  21.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  22.     Set Rng = Rng.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 x = 0 To A
  32.             With IE
  33.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  34.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  35.                  .document.getElementById("StockNo").Value = E
  36.                     .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  37.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  38.                 'End With
  39.                 Do While .Busy Or .readyState <> 4:    Loop
  40.                 Ep .document.getelementsByTagName("TABLE")(7).outerHTML
  41.             End With
  42.         Next x
  43.         xFile = xPath & "\" & E & "\SHD.txt"
  44.         MkDir_Sub xFile
  45.         
  46.         Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
  47.         '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  48.         'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
  49.         
  50.         ii = ii + 1
  51.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
  52.     Next E
  53.     IE.Quit
  54.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  55.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  56. '    ThisWorkbook.Save
  57. End Sub
  58. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  59.           '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  60.           ' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
  61.     Dim fs As Object, E As Range, C As Variant
  62.     Set fs = CreateObject("Scripting.FileSystemObject")
  63.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  64.     For Each E In Q.Rows
  65.         C = Application.Transpose(Application.Transpose(E.Value))
  66.         C = Join(C, vbTab)
  67.         fs.WriteLine C
  68.     Next
  69.     fs.Close
  70. 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兔年全勤獎章
24#
發表於 2014-5-20 15:59 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-5-20 16:01 編輯

回復 61# smart3135
該我說抱歉
  1. 31.        For x = A - 1 To A            
複製代碼
需更正
  1. For x = 0 To A
複製代碼
請在指出哪裡錯誤.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天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兔年全勤獎章
25#
發表於 2014-5-21 16:11 | 顯示全部帖子
回復 63# smart3135

   
成For x = 0 To A，不過出錯訊息和出錯位置仍相同
我測試沒出錯,請說明出錯訊息和出錯位置.
  1. With fs.CreateTextFile(xFile, True)
  2.                 S = Split(A(0).innertext, ")")(1)
  3.                 .WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.
  4.                 For i = 1 To A(2).Rows.Length - 1
  5.                     S = ""
  6.                     For C = 0 To A(2).Rows(i).Cells.Length - 1
  7.                         S = S & A(2).Rows(i).Cells(C).innertext & vbTab
  8.                     Next
  9.                     .WriteLine S
  10.                 Next
  11.                 .Close
  12.             End With
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天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兔年全勤獎章
26#
發表於 2014-5-22 16:04 | 顯示全部帖子

啟

本帖最後由 GBKEE 於 2014-5-22 16:28 編輯

回復 66# smart3135
  1. S = Split(A(0).innertext, ")")(1)
  2.                 .WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.
複製代碼
集保程序我有試著再執行一次，結果還是一樣，出錯訊息如圖

2003版
確定可以寫入股票代號及名稱
集保程序,一樣確定沒有出現錯誤.
你是在2007中執行嗎?(請有2007版測試一下)
希望寫入文字檔的日期資料只要月日就好，也就是4/17
  1. Sub Maketxt(xF As String, Q As Range)    '將匯入資料存入指定的txt
  2.     Dim fs As Object, E As Range, C As Variant, R As Range
  3.     With Q
  4.         .Range("C1").Clear
  5.         .Range("A1") = Q.Range("B1") & " " & "年成交資料"
  6.         .Range("B1").Clear
  7.         .Rows(2).Delete
  8.         .Range("H:H,F:F").NumberFormatLocal = "m/d;@"
  9.         .EntireColumn.AutoFit
  10.     End With
  11.     Set fs = CreateObject("Scripting.FileSystemObject")
  12.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  13.     For Each E In Q.Rows
  14.          C = ""
  15.          For Each R In E.Cells
  16.             C = C & IIf(C <> "", vbTab, "") & R.Text
  17.             'C = Application.Transpose(Application.Transpose(E.Value))
  18.             'C  = Join(C, vbTab)
  19.         Next
  20.         fs.WriteLine C
  21.     Next
  22.     fs.Close
  23. 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兔年全勤獎章
27#
發表於 2014-5-23 15:59 | 顯示全部帖子
回復 69# smart3135
  1. Sub 集保()
  2.     Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
  3.     Dim Ea As Variant, ii As Integer, F As String, H As String, J As Integer, StockNo As Object
  4.     T = Time
  5.     Application.DisplayStatusBar = True
  6.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  7.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  8.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  9.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  10.     xPath = "D:\財報資料"
  11.     IE_Application    '
  12.     Application.StatusBar = " "
  13.     For Each E In Rng
  14.         With Sheets(1)
  15.             .Activate
  16.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  17.         End With
  18.         For x = 0 To A
  19.             With IE
  20.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  21.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  22.                 Set StockNo = .document.getElementById("StockNo")
  23.                 '出錯代碼為"424"，出錯訊息為"此處需要物件",就給它設為物件,2007版試試看是否可行
  24.                 StockNo.Value = E
  25.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  26.                 Do While .Busy Or .readyState <> 4:    Loop
  27.                 If x = 0 Then Sheets(1).Cells(1) = .document.getelementsByTagName("TABLE")(5).INNERTEXT
  28.                 Ep .document.getelementsByTagName("TABLE")(6).INNERTEXT
  29.                 Ep .document.getelementsByTagName("TABLE")(7).outerHTML
  30.             End With
  31.         Next x
  32.         xFile = xPath & "\" & E & "\SHD.txt"
  33.         MkDir_Sub xFile
  34.         Maketxt xFile, Sheets(1).UsedRange, E.Value
  35.         ii = ii + 1
  36.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
  37.     Next E
  38.     IE.Quit
  39.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  40.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  41. '    ThisWorkbook.Save
  42. End Sub
  43. Sub Ep(S As String)
  44.     Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
  45.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  46.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  47.     On Error GoTo ER
  48.     With D
  49.         .SetText S
  50.         .PutInClipboard
  51.         With Sheets(1)
  52.             .Range("a" & .UsedRange.Rows.Count + 1).Select
  53.             Set Rng = Selection
  54.             .PasteSpecial Format:="Unicode 文字"
  55.         End With
  56.     End With
  57.     Exit Sub
  58. ER:
  59.     FormDLL = "FM20.DLL"
  60.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  61.     Resume
  62. 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兔年全勤獎章
28#
發表於 2014-5-25 16:16 | 顯示全部帖子
回復 72# smart3135
  1. Sub 集保()
  2.     Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
  3.     Dim Ea As Variant, ii As Integer, F As String, H As String, j As Integer
  4.     T = Time
  5.     Application.DisplayStatusBar = True
  6.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  7.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  8.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  9.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  10.     xPath = "D:\財報資料"
  11.     IE_Application    '
  12.     IE.Visible = True   '必須顯示IE ,查無資料,按下確定鍵
  13.     Application.StatusBar = " "
  14.     For Each E In Rng
  15.         With Sheets(1)
  16.             .Activate
  17.             .Cells.Clear  '下載資料置於此工作表,變換股票時:清空
  18.         End With
  19.         For x = 0 To A
  20.             With IE
  21.                 .document.getelementsbytagname("select")("SCA_DATE")(x).Selected = True
  22.                '.document.getElementById("StockNo").Value = E  'getElementById於 2007有錯誤
  23.                 .document.ALL("StockNo").Value = E             'ALL 於2007可行
  24.                 .document.getelementsbytagname("INPUT")("sub").Click  '按下查詢
  25.                 On Error Resume Next   '程式有錯誤時:繼續執行下去
  26.                 Do While .Busy Or .readyState <> 4
  27.                     Do
  28.                         Err.Clear
  29.                         'IE接收資料尚未完成 .document.getelementsbytagname("TABLE").Length 會有錯誤
  30.                         If .document.getelementsbytagname("TABLE").Length <= 5 Then '查無資料
  31.                             Application.SendKeys "~", True ' 按下確定鍵
  32.                             GoTo Nextx
  33.                         End If
  34.                     Loop Until Err = 0
  35.                  Loop
  36.                  On Error GoTo 0   '程式有錯誤時:不處裡
  37.                 If x = 0 Then Sheets(1).Cells(1) = .document.getelementsbytagname("TABLE")(5).INNERTEXT
  38.                 Ep .document.getelementsbytagname("TABLE")(6).INNERTEXT
  39.                 Ep .document.getelementsbytagname("TABLE")(7).outerHTML
  40.             End With
  41.         Next x
  42. Nextx:
  43.         If Sheets(1).UsedRange.Rows.Count > 1 Then
  44.             xFile = xPath & "\" & E & "\SHD.txt"
  45.             MkDir_Sub xFile
  46.             Maketxt xFile, Sheets(1).UsedRange, E.Value
  47.             ii = ii + 1
  48.             Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
  49.         End If
  50.     Next E
  51.     IE.Quit
  52.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  53.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  54. '    ThisWorkbook.Save
  55. 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兔年全勤獎章
29#
發表於 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

GBKEE

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

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

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
1234
返回列表 上一主題