- 帖子
- 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基礎，很感謝版主連日來不厭其煩的回答！
- Option Explicit
- Dim IE As Object
- Sub IE_Application()
- Set IE = CreateObject("InternetExplorer.Application")
- With IE
- .Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
- ' .Visible = True '不顯示ie
- Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
- End With
- End Sub
- Sub 上櫃月成交資訊()
- 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
- Dim i As Integer, ii As Integer, t As Date, AR(), Rng, Rng1 As Range, r, C, S
- Set fs = CreateObject("Scripting.FileSystemObject")
- IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
- t = Time
- Application.DisplayStatusBar = True
- '請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
- Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
- Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
- If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
- If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
- Set Rng = Rng.SpecialCells(xlCellTypeConstants)
- Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
- xPath = "D:\財報資料"
- IE_Application '
- Application.StatusBar = " "
- For Each E In Rng
- For Each X In Rng1
- With IE
- Set B = .document.getelementsbytagname("select")("yy")
- B.Value = X
- Set A = .document.getelementbyid("input_stock_code")
- A.Value = E
- A.ParentNode.submit
- Do While .Busy Or .ReadyState <> 4: Loop
- Set A = .document.getelementsbytagname("TABLE")
- xFile = xPath & "\" & E & "\HPM.txt"
- MkDir_Sub xFile
- With fs.CreateTextFile(xFile, True)
- For i = 1 To A(2).Rows.Length - 1
- S = ""
- For C = 0 To A(2).Rows(i).Cells.Length - 1
- S = S & A(2).Rows(i).Cells(C).innertext & vbTab
- Next C
- .WriteLine S
- Next i
- .Close
- End With
- ii = ii + 1
- End With
- Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
- Next X
- Next E
- IE.Quit
- Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
- MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
- ThisWorkbook.Save
- End Sub
- Sub MkDir_Sub(S As String)
- Dim AR, i As Integer, xPath As String
- If Dir(S) = "" Then
- AR = Split(S, "\")
- xPath = AR(0)
- For i = 1 To UBound(AR) - 1
- xPath = xPath & "\" & AR(i)
- If Dir(xPath, vbDirectory) = "" Then MkDir xPath
- Next
- End If
- End Sub
- Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
- Dim fs As Object, E As Range, C As Variant
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
- For Each E In Q.ResultRange.Rows
- C = Application.Transpose(Application.Transpose(E.Value))
- C = Join(C, vbTab)
- fs.WriteLine C
- Next
- fs.Close
- End Sub
 test2.zip (17.73 KB)
|
|
發表於 2014-4-30 10:27
| 
