Option Explicit
Public eachcode(20000) As String
Public DataDate() As String
Sub Query()
Dim objIE As InternetExplorer
Dim objDoc As HTMLDocument
Dim objTable As HTMLTable
Dim objRow As HTMLTableRow
Dim strURL As String
Dim i As Integer, j As Integer, m As Integer, n As Integer, ri As Integer, rj As Integer
Dim NumDate As Integer
Dim Fn As String
Dim A1() As String
Dim InputStr, S3, vfname As String
Dim vdata As Variant
Dim arows, acols As Long
Fn = FreeFile
Open ActiveWorkbook.Path & "\" & "stockcode.txt" For Input As #Fn '開啟 stockcode.txt 檔
Application.ScreenUpdating = False '畫面暫停更新
m = 0
While Not EOF(Fn)
Line Input #Fn, InputStr '從檔案讀出一列,
If Len(InputStr) > 0 Then '略過無字串的空行
eachcode(m) = Trim(InputStr)
'把讀入的文字列置於 eachcode 陣列裡
End If
m = m + 1
Wend
Application.ScreenUpdating = True '畫面恢復更新
Close #Fn
strURL = "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
Set objIE = New InternetExplorer
With objIE
.Navigate strURL
' .Visible = True
Do While .Busy Or .ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
Set objDoc = .Document
End With
NumDate = objDoc.getElementsByName("SCA_DATE").Item.Length
ReDim DataDate(NumDate - 1)
For i = 0 To NumDate - 1
DataDate(i) = objDoc.getElementsByName("SCA_DATE").Item.Item(i).innerText
Next
S3 = ""
ChDir ActiveWorkbook.Path & "\"
On Error Resume Next '
For n = 0 To m - 1
Application.Windows(ThisWorkbook.Name).Activate
'Sheet1.Activate
Cells.Select
Selection.Clear
Cells(1, 1) = eachcode(n)
For i = 0 To NumDate - 1
With objDoc
.getElementsByName("StockNo").Item.Value = eachcode(n)
.getElementsByName("SCA_DATE").Item.selectedIndex = i
.getElementsByName("sub").Item.Click
End With
Application.Wait Now + TimeSerial(0, 0, 3)
Application.ScreenUpdating = False
Set objTable = objDoc.getElementsByTagName("TABLE").Item(7)
For ri = 0 To objTable.Rows.Length - 1
Set objRow = objTable.Rows(ri)
For rj = 0 To objRow.Cells.Length - 1
Cells(3 + 20 * i + ri, 1 + rj) = objRow.Cells(rj).innerText
Next
Next
'Range(Cells(1 + 20 * i, 1), Cells(1 + 20 * i, 5)).EntireColumn.AutoFit
Cells(1 + 20 * i, 2) = objDoc.getElementsByTagName("TABLE").Item(5).innerText
Cells(1 + 20 * i, 5) = objDoc.getElementsByTagName("TABLE").Item(6).innerText
Application.ScreenUpdating = True
Next
ActiveSheet.UsedRange.Select
arows = Selection.Rows.Count
acols = Selection.Columns.Count
vfname = eachcode(n) + ".csv"
Open vfname For Output As #1 '定義Output File位置
For i = 1 To arows
For j = 1 To acols - 1
vdata = Selection.Cells(i, j).Text
vdata = Replace(vdata, ",", "")
Write #1, vdata;
Next j
Write #1, Selection.Cells(i, acols).Text
Next i
Close #1
Next
objIE.Quit
Set objRow = Nothing
Set objTable = Nothing
Set objDoc = Nothing
Set objIE = Nothing
End Sub作者: GBKEE 時間: 2015-3-8 10:39
