麻辣家族討論版版 - Powered by Discuz! Board

Dim ie As Object '模組最頂端 Dim 供這模組的程序使用的變數
Sub AllFile()
Dim i As Integer, v, Y As Integer, S As String
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
With ie '縮小IE視窗
.Visible = True
.Width = 5
.Height = 5
End With
With 工作表1
Dim AR
AR = .Range("E1:M1")
.Range("E:M") = ""
.Range("E1:M1") = AR
' .Range("E2").CurrentRegion = "" '清除工作表1,年度範圍
v = "2330"
GetDividend (v)
GetClosePrice (v)
GetIncome (v)
GetBalance (v)
GetShareholding (v)
Debug.Print v
End With
With ie 'IE視窗最大化
Application.WindowState = xlMaximized
.Height = Application.Height
.Width = Application.Width
.Quit
End With
End Sub
Private Sub GetDividend(ByVal ss As String) '取股利網頁
Dim rr As String, T As Date, i, ii, k, j, S As Object
T = Time
rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcc/zcc_" & ss & ".djhtm"
With ie
.Navigate rr
Do While .readyState <> 4 '等待網頁下載完畢
DoEvents
If Time >= T + #12:00:03 AM# Then
DoEvents
Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
Exit Do
End If
Loop
Do
Set S = .Document.getElementsByTagName("table")(2)
Loop Until Not S Is Nothing
With 工作表2
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
.Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
DoEvents
Next
Next
End With
End With
End Sub
Private Sub GetClosePrice(ByVal ss As String) ' 取基本資料
Dim rr As String, T As Date, i, ii, k, j, S As Object
T = Time
rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zca/zca_" & ss & ".djhtm"
With ie
.Navigate rr
Do While .readyState <> 4 '等待網頁下載完畢
DoEvents
If Time >= T + #12:00:03 AM# Then
DoEvents
Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
Exit Do
End If
Loop
Do
Set S = .Document.getElementsByTagName("table")(2)
Loop Until Not S Is Nothing
With 工作表3
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
.Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
DoEvents
Next
Next
End With
End With
End Sub
Private Sub GetIncome(ByVal ss As String) '取損益表(年表)網頁
Dim rr As String, T As Date, i, ii, k, j, S As Object
T = Time
rr = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_" & ss & ".djhtm"
With ie
.Navigate rr
Do While .readyState <> 4 '等待網頁下載完畢
DoEvents
If Time >= T + #12:00:03 AM# Then
DoEvents
Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
Exit Do
End If
Loop
Do
Set S = .Document.getElementsByTagName("table")(2)
Loop Until Not S Is Nothing
With 工作表4
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
.Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
DoEvents
Next
Next
End With
End With
End Sub
Private Sub GetBalance(ByVal ss As String) '取資產負債表(年表)網頁
Dim rr As String, T As Date, i, ii, k, j, S As Object
T = Time
rr = "http://kgieworld.moneydj.com/z/zc/zcp/zcpb/zcpb_" & ss & ".djhtm"
With ie
.Navigate rr
Do While .readyState <> 4 '等待網頁下載完畢
DoEvents
If Time >= T + #12:00:03 AM# Then
DoEvents
Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
Exit Do
End If
Loop
Do
Set S = .Document.getElementsByTagName("table")(2)
Loop Until Not S Is Nothing
With 工作表5
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
.Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
DoEvents
Next
Next
End With
End With
End Sub
Private Sub GetShareholding(ByVal ss As String) '取董監持股網頁
Dim rr As String, T As Date, i, ii, k, j, S As Object
T = Time
rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcj/zcj_" & ss & ".djhtm" '取董監持股網頁
With ie
.Navigate rr
Do While .readyState <> 4 '等待網頁下載完畢
DoEvents
If Time >= T + #12:00:03 AM# Then
DoEvents
Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
Exit Do
End If
Loop
Do
Set S = .Document.getElementsByTagName("table")(3)
Loop Until Not S Is Nothing
With 工作表6
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
.Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
DoEvents
Next
Next
End With
End With
End Sub

複製代碼