12345678910
返回列表 上一主題 發帖

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
61# 跳轉到 »
發表於 2014-5-19 19:06 | 只看該作者
回復 60# GBKEE
版主抱歉，請問一下，我將您提供的程式碼代入後出錯位置及出錯訊息仍和之前一樣，能麻煩您再幫忙看一下嗎？感恩！
集保最新.zip (27.46 KB)
  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 = A - 1 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 Ep(S As String)
  59.     Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
  60.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  61.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  62.     On Error GoTo ER
  63.     With D
  64.         .SetText S
  65.         .PutInClipboard
  66.         With Sheets(1)
  67.             .Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
  68.             .PasteSpecial Format:="Unicode 文字"
  69. '            Set Rng = Selection
  70. '                Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  71.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  72.                 :=xlStroke, DataOption1:=xlSortNorma
  73.         End With
  74.     End With
  75.     Exit Sub
  76. ER:
  77.     FormDLL = "FM20.DLL"
  78.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  79.     Resume
  80. End Sub
  81. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  82.           '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  83.           ' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
  84.     Dim fs As Object, E As Range, C As Variant
  85.     Set fs = CreateObject("Scripting.FileSystemObject")
  86.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  87.     For Each E In Q.Rows
  88.         C = Application.Transpose(Application.Transpose(E.Value))
  89.         C = Join(C, vbTab)
  90.         fs.WriteLine C
  91.     Next
  92.     fs.Close
  93. End Sub
  94. Sub MkDir_Sub(S As String)
  95.     Dim AR, I As Integer, xPath As String
  96.     If Dir(S) = "" Then
  97.         AR = Split(S, "\")
  98.         xPath = AR(0)
  99.         For I = 1 To UBound(AR) - 1
  100.             xPath = xPath & "\" & AR(I)
  101.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  102.         Next
  103.     End If
  104. 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兔年全勤獎章
62#
發表於 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
63#
發表於 2014-5-21 09:28 | 只看該作者
回復 62# GBKEE
版主您好，不好意思，我有試著將For x = A - 1 To A 改成For x = 0 To A，不過出錯訊息和出錯位置仍相同，能不能再麻煩您測試一下呢？
另外在更之前的上櫃年成交資料，就是用比較舊的寫法，不貼上EXCEL直接寫入TXT的程式碼，雖然有資料，不過最上方少了個股代號和名稱，不知這部分能不能
也擷取到資料並寫入TXT？或是是有可以先貼到EXCEL再寫入TXT的方法？再麻煩您了！
  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 Ep(S As String)
  59.     Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
  60.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  61.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  62.     On Error GoTo ER
  63.     With D
  64.         .SetText S
  65.         .PutInClipboard
  66.         With Sheets(1)
  67.             .Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
  68.             .PasteSpecial Format:="Unicode 文字"
  69. '            Set Rng = Selection
  70. '                Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  71.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  72.                 :=xlStroke, DataOption1:=xlSortNorma
  73.         End With
  74.     End With
  75.     Exit Sub
  76. ER:
  77.     FormDLL = "FM20.DLL"
  78.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  79.     Resume
  80. End Sub
  81. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  82.           '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  83.           ' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
  84.     Dim fs As Object, E As Range, C As Variant
  85.     Set fs = CreateObject("Scripting.FileSystemObject")
  86.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  87.     For Each E In Q.Rows
  88.         C = Application.Transpose(Application.Transpose(E.Value))
  89.         C = Join(C, vbTab)
  90.         fs.WriteLine C
  91.     Next
  92.     fs.Close
  93. End Sub
  94. Sub MkDir_Sub(S As String)
  95.     Dim AR, I As Integer, xPath As String
  96.     If Dir(S) = "" Then
  97.         AR = Split(S, "\")
  98.         xPath = AR(0)
  99.         For I = 1 To UBound(AR) - 1
  100.             xPath = xPath & "\" & AR(I)
  101.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  102.         Next
  103.     End If
  104. End Sub
複製代碼
  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 = "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 & "\HPY.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
複製代碼
程式碼與資料不足TXT.zip (46.93 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兔年全勤獎章
64#
發表於 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
65#
發表於 2014-5-21 20:17 | 只看該作者
回復 64# GBKEE
版主您好，集保程序我有試著再執行一次，結果還是一樣，出錯訊息如圖：


另外您提供的程式碼我有加入上櫃年成交中，最上方是有寫入了，不過是寫入空白資料，不是股票代號和名稱，能麻煩您再看一下嗎？
  1. Sub 上櫃年成交資訊()
  2.     Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
  3.     Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
  4.     Set fs = CreateObject("Scripting.FileSystemObject")
  5.     IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
  6.     t = Time
  7.     Application.DisplayStatusBar = True
  8.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  9.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  10.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  11.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  12.     xPath = "D:\財報資料"
  13.     IE_Application    '
  14.     Application.StatusBar = " "
  15.     For Each E In Rng
  16.         With IE
  17.             Set A = .Document.getelementbyid("input_stock_code")
  18.             A.Value = E
  19.             A.ParentNode.submit
  20.             Do While .Busy Or .ReadyState <> 4:    Loop
  21.             Set A = .Document.getelementsbytagname("TABLE")
  22.             xFile = xPath & "\" & E & "\HPY.txt"
  23.             MkDir_Sub xFile
  24.             With fs.CreateTextFile(xFile, True)
  25.                 S = Split(A(0).innertext, ")")(1)
  26.                 .WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.
  27.                 For i = 1 To A(2).Rows.Length - 1
  28.                     S = ""
  29.                     For C = 0 To A(2).Rows(i).Cells.Length - 1
  30.                         S = S & A(2).Rows(i).Cells(C).innertext & vbTab
  31.                     Next
  32.                     .WriteLine S
  33.                 Next
  34.                 .Close
  35.             End With
  36.             ii = ii + 1
  37.         End With
  38.         Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔"
  39.     Next
  40.     IE.Quit
  41.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔,  讀取完畢 !! "
  42.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  43. '    ThisWorkbook.Save
  44. End Sub
複製代碼

TOP

smart3135

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

回復 64# GBKEE
版主您好，今天利用上櫃月成交資料的程式碼來做了一些修正，已經可以順利擷取上櫃年成交資料了，只是還有一些小問題：
1.多餘的語法該刪除的我應該都刪除了，不確定有沒有多餘不必要的語法沒被刪除
2.在擷取資料貼到EXCEL後，日期的部分會變成文字，請見附圖，不過網頁顯示的只是單純的日期
舉例來說：網頁顯示的表格是4/17，但匯入EXCEL後就會變成4月17日，而寫入文字檔時則變成2014/4/17
我有試著在匯入EXCEL之前將日期欄位的儲存格格式先設定成文字，不過貼上EXCEL後還是會被修改格式
我希望寫入文字檔的日期資料只要月日就好，也就是4/17，不知道這部分有沒有辦法修改？
另外如65#回覆，集保戶資料的問題還是未能解決，再麻煩您幫忙看一下囉！感謝！

  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/st42.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, T As Date, xPath As String, xFile As String
  14.     Dim Ea As Variant, AR(), ii As Integer
  15.     T = Time
  16.     Application.DisplayStatusBar = True
  17.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  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.     xPath = "G:\財報資料"
  22.     IE_Application
  23.     Application.StatusBar = " "
  24.     For Each E In Rng
  25.         Sheets(1).UsedRange.Clear            '下載資料置於此工作表,變換股票時:清空
  26.             With IE
  27.                  With .document.getelementbyid("input_stock_code")
  28.                     .Value = E
  29.                     .ParentNode.submit
  30.                 End With
  31.                 Do While .Busy Or .readyState <> 4:    Loop
  32.                 If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
  33.                     AR = Array(0, 2)
  34. '                Else
  35. '                    AR = Array(2)
  36.                 End If
  37.                 For Each Ea In AR
  38.                     Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
  39.                 Next
  40.             End With
  41.         ii = ii + 1
  42.         xFile = xPath & "\" & E & "\HPM.txt"
  43.         MkDir_Sub xFile
  44.         Maketxt xFile, Sheets(1).UsedRange
  45.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃" & E & "年成交 " & ii & " 文字檔"
  46.     Next E
  47.     IE.Quit
  48.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔,  讀取完畢 !! "
  49.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  50. End Sub
  51. Sub Ep(S As String)
  52.     Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
  53.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  54.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  55.     On Error GoTo ER
  56.     With D
  57.         .SetText S
  58.         .PutInClipboard
  59.         With Sheets(1)
  60.             .Range("a" & .Rows.Count).End(xlUp).Select
  61.             If .Range("a1") <> "" Then .Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
  62.             .PasteSpecial Format:="Unicode 文字"
  63.         End With
  64.     End With
  65.     Exit Sub
  66. ER:
  67.     FormDLL = "FM20.DLL"
  68.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  69.     Resume
  70. End Sub
  71. Sub MkDir_Sub(S As String)
  72.     Dim AR, i As Integer, xPath As String
  73.     If Dir(S) = "" Then
  74.         AR = Split(S, "\")
  75.         xPath = AR(0)
  76.         For i = 1 To UBound(AR) - 1
  77.             xPath = xPath & "\" & AR(i)
  78.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  79.         Next
  80.     End If
  81. End Sub
  82. Sub Maketxt(xF As String, Q As Range)    '將匯入資料存入指定的txt
  83.     Dim fs As Object, E As Range, C As Variant
  84.     Q.Range("C1").Clear
  85.     Q.Range("A1") = Q.Range("B1") & " " & "年成交資料"
  86.     Q.Range("B1").Clear
  87.     Q.Rows(2).Delete
  88.     Set fs = CreateObject("Scripting.FileSystemObject")
  89.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  90.     For Each E In Q.Rows
  91.         C = Application.Transpose(Application.Transpose(E.Value))
  92.         C = Join(C, vbTab)
  93.         fs.WriteLine C
  94.     Next
  95.     fs.Close
  96. End Sub
複製代碼
上櫃年成交資訊.zip (20.05 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兔年全勤獎章
67#
發表於 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
68#
發表於 2014-5-22 19:22 | 只看該作者
回復 67# GBKEE
版主您好，因為我有雙系統，一個是WIN7+2007，一個是XP+2003，我平常都是開WIN7的，經你提醒，今天試著用2003跑一次集保程序
結果真的可以執行，不會出錯，但在2007卻會出錯，這部分可能還要再研究一下為什麼會這樣
另外寫入日期部分經帶入您的程式碼後已可正常寫入日期，再次感謝您大力協助，謝謝您！

TOP

smart3135

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

回復 67# GBKEE
版主您好，經過今天早上不斷使用2003版測試，終於做出我想要的輸出文字檔結果，不過還是有些問題會發生，先附上程式碼與附檔
集保戶-新.zip (128.04 KB)
這裡是完整的程式碼
  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.     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 = "E:\財報資料"
  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.             With IE
  32.                 .document.getElementById("StockNo").Value = E
  33.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  34.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  35.                 Do While .Busy Or .readyState <> 4:    Loop
  36.                 Ep .document.getelementsByTagName("TABLE")(5).outerHTML
  37.             End With
  38.         
  39.         For x = 0 To A
  40.             With IE
  41.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  42.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  43.                 .document.getElementById("StockNo").Value = E
  44.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  45.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  46.                 Do While .Busy Or .readyState <> 4:    Loop
  47.                 Ep .document.getelementsByTagName("TABLE")(6).outerHTML
  48.             End With
  49.             With IE
  50.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  51.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  52.                 .document.getElementById("StockNo").Value = E
  53.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  54.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  55.                 Do While .Busy Or .readyState <> 4:    Loop
  56.                 Ep .document.getelementsByTagName("TABLE")(7).outerHTML
  57.             End With
  58.         Next x
  59.         With Sheets(1)
  60.             F = .Range("a3")
  61.             J = Len(F)
  62.             If J >= 19 Then
  63.                 H = Mid(F, 1, 3)
  64.             Else
  65.                 H = Mid(F, 1, 2)
  66.             End If
  67.             .Range("a1") = E & "-" & H & " " & "集保戶股權分散表"
  68.             .Rows("2:4").Delete
  69.         End With
  70.         xFile = xPath & "\" & E & "\SHD.txt"
  71.         MkDir_Sub xFile
  72.         Maketxt xFile, Sheets(1).UsedRange, E.Value
  73.         '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  74.         'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
  75.         ii = ii + 1
  76.         Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
  77.     Next E
  78.     IE.Quit
  79.     Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔,  讀取完畢 !! "
  80.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
  81. '    ThisWorkbook.Save
  82. End Sub
  83. Sub Ep(S As String)
  84.     Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
  85.     'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
  86.     '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
  87.     On Error GoTo ER
  88.     With D
  89.         .SetText S
  90.         .PutInClipboard
  91.         With Sheets(1)
  92.             .Range("a" & .Rows.Count).End(xlUp).Select
  93.             Set Rng = Selection
  94.             If Rng = 15 Then
  95.                 Rng.Offset(3).Select
  96.             Else
  97.                 Rng.Offset(2).Select
  98.             End If
  99.             .PasteSpecial Format:="Unicode 文字"
  100. '            If Selection = "" Then Selection.Offset(1).Select
  101. '            Set Rng = Selection
  102. '                Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
  103.                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  104.                 :=xlStroke, DataOption1:=xlSortNorma
  105.         End With
  106.     End With
  107.     Exit Sub
  108. ER:
  109.     FormDLL = "FM20.DLL"
  110.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  111.     Resume
  112. End Sub
  113. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  114.           '***想請問您Code As String的Code是怎麼帶出個股編號的 ****
  115.           ' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
  116.     Dim fs As Object, E As Range, C As Variant
  117.     Set fs = CreateObject("Scripting.FileSystemObject")
  118.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  119.     For Each E In Q.Rows
  120.         C = Application.Transpose(Application.Transpose(E.Value))
  121.         C = Join(C, vbTab)
  122.         fs.WriteLine C
  123.     Next
  124.     fs.Close
  125. End Sub
  126. Sub MkDir_Sub(S As String)
  127.     Dim AR, I As Integer, xPath As String
  128.     If Dir(S) = "" Then
  129.         AR = Split(S, "\")
  130.         xPath = AR(0)
  131.         For I = 1 To UBound(AR) - 1
  132.             xPath = xPath & "\" & AR(I)
  133.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  134.         Next
  135.     End If
  136. End Sub
複製代碼
因為我要的文字檔除了個股代號和名稱之外，還有日期也要一併寫入，所以我就自己加了以下這些東西
  1.             With IE
  2.                 .document.getElementById("StockNo").Value = E
  3.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  4.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  5.                 Do While .Busy Or .readyState <> 4:    Loop
  6.                 Ep .document.getelementsByTagName("TABLE")(5).outerHTML
  7.             End With
  8.         
  9.         For x = 0 To A
  10.             With IE
  11.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  12.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  13.                 .document.getElementById("StockNo").Value = E
  14.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  15.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  16.                 Do While .Busy Or .readyState <> 4:    Loop
  17.                 Ep .document.getelementsByTagName("TABLE")(6).outerHTML
  18.             End With
  19.             With IE
  20.                 .document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
  21.                                             '這裡的資料日期 需用 Select 它是有[年度月份日期]的
  22.                 .document.getElementById("StockNo").Value = E
  23.                 .document.getelementsByTagName("INPUT")("sub").Click  '按下查詢
  24.                        '這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
  25.                 Do While .Busy Or .readyState <> 4:    Loop
  26.                 Ep .document.getelementsByTagName("TABLE")(7).outerHTML
  27.             End With
複製代碼
1.首先第一段是為了要擷取("TABLE")(5)才能匯入個股名稱，所以我加了這些語法，由於個股名稱只需要擷取一次
    所以將這段語法寫在x迴圈之外，但不知道這樣的語法正不正確
2.因為要擷取的日期是在("TABLE")(6)，所以將這段也寫入，就只是複製("TABLE")(7)的改成6而已，也不確定這樣寫到底正不正確
3.以上程式碼在2003使用F8逐行執行時是可以正常的，但使用F5連續執行時有時會出錯，不然就是("TABLE")(5)和("TABLE")(6)會有資料重覆或者漏抓
    以("TABLE")(6)抓到的日期來說，會抓到兩個一樣的日期(日期錯誤)，但資料內容的("TABLE")(7)卻是不同的(內容正確)，也就是日期和資料內容對不上
    不知道是不和我的語法有問題

另外先前向您提過，用2007執行上述程式碼時會出錯，出錯代碼為"424"，出錯訊息為"此處需要物件"，我有點說明進去看，但真的看不太懂
我將說明內容存成PDF一起放在附件中，可以的話再麻煩您看看是不是可以找出為什麼這個程式碼沒法在2007執行的原因，再次感謝您！

TOP

GBKEE

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

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

        靜思自在 : 人生最大的成就是從失敗中站起來。
12345678910
返回列表 上一主題