12345678910
返回列表 上一主題 發帖

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

GBKEE

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

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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
55#
發表於 2014-5-17 13:38 | 只看該作者
回復 51# GBKEE
不好意思，GBKEE版主，又發現一個比較大的問題了，我想要的資料是近三年的月成交資料，可是有些個股是近1-2年才上市櫃的，所以在上市網頁輸入時會出現查無
而在上櫃網頁則是只會出現上櫃後開始的月成交資料，當查到上市櫃前的年份就會出現查無，如果讓VBA直接執行的話，執行到上市櫃不到三年的個股代號就會出錯
還會有無窮迴圈的狀況，不知道有沒有辦法加入其他程式碼來避免這種錯誤？
舉例來說：如果個股只有上市櫃不到一年、或一年到兩年，能不能只擷取該個股有的資料，當遇到查無的年份就結束該個股的資料擷取，跳到下一個股
附件是我將Sheet(3)代入一些上市櫃不到三年的個股代號會出錯的EXCEL，再請您指導一下，謝謝！

上市櫃月成交資訊.zip (37.25 KB)

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
54#
發表於 2014-5-16 19:09 | 只看該作者
回復 53# GBKEE
版主您好，不好意思，請問一下加了a=Q.Cells(1)有什麼不同呢?雖然執行時不會出錯，不過結果還是沒變，因為執行到下面，輸出的結果還是Q.Cells(1) = Code & "月成交資訊"
我試著再修改了一下，不過還是如之前會出錯，不知您說的變通是指？？？？？
  1. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  2.     Dim fs As Object, E As Range, C As Variant
  3.     Dim A As String, B As String
  4.     A = Q.Cells(1)
  5. '    B = Mid(A, 9, 20)　　'這段程式碼加入的話就會出錯,用註解跳過則不會出錯,但這段程式碼是要擷取正確文字
  6.     Set fs = CreateObject("Scripting.FileSystemObject")
  7.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  8.     Q.Cells(1) = Code & B   '加入股票代號
  9.     For Each E In Q.Rows
  10.         C = Application.Transpose(Application.Transpose(E.Value))
  11.         C = Join(C, vbTab)
  12.         fs.WriteLine C
  13.     Next
  14.     fs.Close
  15. 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兔年全勤獎章
53#
發表於 2014-5-16 15:57 | 只看該作者
回復 52# smart3135
Q.Cells(1) 有不可見字元如圖,會造成程式碼的錯誤,所以變通一下
  1. Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
52#
發表於 2014-5-16 08:28 | 只看該作者
回復 51# GBKEE
感謝GBKEE版主，這些程式碼又讓我學到很多，我也試著將上櫃資料自行排序，試了許久，終於成功了
不過這個上市在寫入文字檔的程式碼中有一些不太了解，想再向您請益：
1.和市櫃不同的地方是多了一個Code，而這個Code會直接代入E的代號，想請問這個Code是什麼？
2.在 [Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號]這段程式碼的結果會變成[股票代號&月成交資訊]，因為我想除了連股票代號之外，連股票名稱也能顯示
舉例來說：跑第一檔股票時結果會是"1101月成交資訊"，我想要的結果是"1101亞泥月成交資訊"，我有試著用原來A1儲存格保留的"103年1101亞泥月成交資訊"
來做修改，有用mid函數，也有用replce，並將[Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號]用註解跳過，但只要這段跳過就會在fs.WriteLine C出錯
如果不跳過，在這裡加入其他程式碼一樣會在fs.WriteLine C出錯，不清楚為何會這樣？

原來的程式碼
  1. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  2.     Dim fs As Object, E As Range, C As Variant
  3.     Set fs = CreateObject("Scripting.FileSystemObject")
  4.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  5.     Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號
  6.     For Each E In Q.Rows
  7.         C = Application.Transpose(Application.Transpose(E.Value))
  8.         C = Join(C, vbTab)
  9.         fs.WriteLine C
  10.     Next
  11.     fs.Close
  12. End Sub
複製代碼
我自己修改的程式碼(會出錯)
  1. Sub Maketxt(xF As String, Q As Range, Code As String)     '將匯入資料存入指定的txt
  2.     Dim fs As Object, E As Range, C As Variant, A As String, B As String
  3.     Set fs = CreateObject("Scripting.FileSystemObject")
  4.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  5.     A = Q.Cells(1)
  6.     B = Mid(A, 5, 15)
  7.     Q.Cells(1) = B
  8. '    Q.Cells(1) = Code & " 月成交資訊"   '加入股票代號
  9.     For Each E In Q.Rows
  10.         C = Application.Transpose(Application.Transpose(E.Value))
  11.         C = Join(C, vbTab)
  12.         fs.WriteLine C
  13.     Next
  14.     fs.Close
  15. 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兔年全勤獎章
51#
發表於 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
50#
發表於 2014-5-12 00:04 | 只看該作者
回復 49# GBKEE
感謝GBKEE版主，49#程式碼我研究了幾天，不過還是太深奧了，有看沒有很懂，但實際上執行結果是成功的，有試著依樣畫葫蘆，將上市的網頁連結及相關引數帶入程式碼試著擷取資料
但在跑到 .ParentNode.submit會出現沒有使用權限，因為不懂這段程式碼的意思，能請您再幫忙一下嗎？
另外不知道在49#的執行結果中，有沒有辦法將月份越新的往上排序呢？再麻煩您一下囉！感謝！
例如：程式執行結果為
103年1月
103年2月
103年3月
103年4月

希望結果為
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 = "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")("myear").Value = X
  31.                  With .Document.getelementbyid("STK_NO")
  32.                     .Value = E
  33.                     .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
  34.                     .ParentNode.submit
  35.                 End With
  36.                 Do While .Busy Or .readyState <> 4:    Loop
  37.                 If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
  38.                     ar = Array(0, 2)
  39.                 Else
  40.                     ar = Array(2)
  41.                 End If
  42.                 For Each Ea In ar
  43.                     Ep .Document.getElementsByTagName("TABLE")(Ea).outerHTML
  44.                 Next
  45.             ii = ii + 1
  46.             End With
  47.         Next X
  48.         xFile = xPath & "\" & E & "\HPM.txt"
  49.         MkDir_Sub xFile
  50.         Maketxt xFile, Sheets(1).UsedRange
  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
  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.         End With
  70.     End With
  71.     Exit Sub
  72. ER:
  73.     FormDLL = "FM20.DLL"
  74.     ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
  75.     Resume
  76. End Sub
  77. Sub MkDir_Sub(S As String)
  78.     Dim ar, i As Integer, xPath As String
  79.     If Dir(S) = "" Then
  80.         ar = Split(S, "\")
  81.         xPath = ar(0)
  82.         For i = 1 To UBound(ar) - 1
  83.             xPath = xPath & "\" & ar(i)
  84.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  85.         Next
  86.     End If
  87. End Sub
  88. Sub Maketxt(xF As String, Q As Range)    '將匯入資料存入指定的txt
  89.     Dim fs As Object, E As Range, C As Variant
  90.     Q.Range("C1") = ""
  91.     Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
  92.     Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  93.     Set fs = CreateObject("Scripting.FileSystemObject")
  94.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  95.     For Each E In Q.Rows
  96.         C = Application.Transpose(Application.Transpose(E.Value))
  97.         C = Join(C, vbTab)
  98.         fs.WriteLine C
  99.     Next
  100.     fs.Close
  101. End Sub
複製代碼
上市.zip (20.75 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兔年全勤獎章
49#
發表於 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

smart3135

帖子
96 
主題
18 
精華
0 
積分
125 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-3-23 
最後登錄
2022-8-2 
48#
發表於 2014-5-5 05:57 | 只看該作者
回復 47# GBKEE
感謝版主耐心的回答，看了文章之後，大概了解了相對引數的關鍵字，也有試著將相對引數"select"和"yy"代入，結果是可行的
不過有點問題：
1.在迴圈執行程式時是會依照我在sheet(3) B欄輸入的年份匯入文字檔，不過下一年份的資料又會覆蓋原來的文字檔內容
    例如我在sheet(3) B欄輸入的年份是2014、2013、2012，結果2014的寫完後再寫下一筆的2013就會把原來寫入的2014覆蓋掉
    不知道能不能將三年的資料都寫入文字檔？
2.年份迴圈是否只能利用像個股代號一樣在sheet(3) 某欄輸入想要擷取的年份資料，能不能直接寫入VBA中呢？
3.寫入的文字檔是從開始有數字資料時寫起，不知道能不能由最上方個股代號那一列開始寫入，也就是文字檔中會看得到個股代號
4.因為這個VBA程式是直接將資料寫入文字檔，無法看到資料匯入EXCEL的動作，不知道能不能做日期排序
    例如寫入的第一年份資料由上到下是103年1月份到103年5月份，不知道能不能將5月份寫到最上方
我想問題會這麼多，應該是我VBA基礎還沒打好就急於學習更進階的東西，看來我可能得多看些書、文章、影片充實自己的VBA基礎，很感謝版主連日來不厭其煩的回答！

  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 E, X As Range, xPath As String, xFile As String, A, B 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, Rng1 As Range, r, C, S
  14.     Set fs = CreateObject("Scripting.FileSystemObject")
  15.     IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
  16.     t = Time
  17.     Application.DisplayStatusBar = True
  18.     '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
  19.     Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
  20.     Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
  21.     If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
  22.     If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
  23.     Set Rng = Rng.SpecialCells(xlCellTypeConstants)
  24.     Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
  25.     xPath = "D:\財報資料"
  26.     IE_Application    '
  27.     Application.StatusBar = " "
  28.     For Each E In Rng
  29.         For Each X In Rng1
  30.             With IE
  31.                 Set B = .document.getelementsbytagname("select")("yy")
  32.                 B.Value = X
  33.                 Set A = .document.getelementbyid("input_stock_code")
  34.                 A.Value = E
  35.                 A.ParentNode.submit
  36.                 Do While .Busy Or .ReadyState <> 4:    Loop
  37.                 Set A = .document.getelementsbytagname("TABLE")
  38.                 xFile = xPath & "\" & E & "\HPM.txt"
  39.                 MkDir_Sub xFile
  40.                 With fs.CreateTextFile(xFile, True)
  41.                     For i = 1 To A(2).Rows.Length - 1
  42.                         S = ""
  43.                         For C = 0 To A(2).Rows(i).Cells.Length - 1
  44.                             S = S & A(2).Rows(i).Cells(C).innertext & vbTab
  45.                         Next C
  46.                         .WriteLine S
  47.                     Next i
  48.                     .Close
  49.                 End With
  50.             ii = ii + 1
  51.             End With
  52.         Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
  53.         Next X
  54.     Next E
  55.     IE.Quit
  56.     Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔,  讀取完畢 !! "
  57.     MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
  58.     ThisWorkbook.Save
  59. End Sub
  60. Sub MkDir_Sub(S As String)
  61.     Dim AR, i As Integer, xPath As String
  62.     If Dir(S) = "" Then
  63.         AR = Split(S, "\")
  64.         xPath = AR(0)
  65.         For i = 1 To UBound(AR) - 1
  66.             xPath = xPath & "\" & AR(i)
  67.             If Dir(xPath, vbDirectory) = "" Then MkDir xPath
  68.         Next
  69.     End If
  70. End Sub
  71. Sub Maketxt(xF As String, Q As QueryTable)   '將匯入資料存入指定的txt
  72.     Dim fs As Object, E As Range, C As Variant
  73.     Set fs = CreateObject("Scripting.FileSystemObject")
  74.     Set fs = fs.CreateTextFile(xF, True)  '創見一個檔案,如檔案存在可覆蓋掉
  75.     For Each E In Q.ResultRange.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
複製代碼
test2.zip (17.73 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兔年全勤獎章
47#
發表於 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

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
12345678910
返回列表 上一主題