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

Option Explicit
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
'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
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) ' 新的 table 4
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
'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
T = Time
'rr = "http://dj.mybank.com.tw/z/zc/zca/zca_" & ss & ".asp.htm" '取(基本資料) 收盤價本益比負債比網頁
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) ' 新的 table 4
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://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?Select_Table=html\YFinain\&StockID=" & ss '取損益表(年表)網頁
rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcq/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) ' 新的 table 4
Loop Until Not S Is Nothing
With 工作表4
.UsedRange.Clear
For i = 0 To S.Rows.Length - 1 '寫入資料
k = k + 1
'For j = 0 To S.Rows(i).Length - 1 '這行是錯誤的也是多餘的迴圈
'用 On Error Resume Next 使程式繼續執行
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
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
'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
T = Time
rr = "http://pscnetinvest.moneydj.com.tw/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) ' 新的 table 4
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
'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
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) ' 新的 table 4
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

複製代碼

Option Explicit
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,年度範圍
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
v = .Cells(i, 1).Value
'''''
GetDividend (v)
GetClosePrice (v)
GetIncome (v)
GetBalance (v)
GetShareholding (v)
.Cells(i, 5).Value = 工作表2.Cells(5, 2).Value
.Cells(i, 6).Value = 工作表2.Cells(5, 3).Value
.Cells(i, 7).Value = 工作表3.Cells(2, 8).Value
.Cells(i, 8).Value = .Cells(i, 5).Value / .Cells(i, 7).Value '現金殖利率
On Error Resume Next
' .Cells(i, 8).NumberFormatLocal = "0.00%"
.Cells(i, 9).Value = 工作表4.Cells(66, 2).Value / 工作表5.Cells(94, 2).Value 'ROE%
On Error Resume Next
.Cells(i, 10).Value = 工作表3.Cells(4, 2).Value '本益比
.Cells(i, 11).Value = 工作表3.Cells(12, 4).Value '股價淨值比
.Cells(i, 12).Value = 工作表3.Cells(11, 4).Value '負債比%
' .Cells(i, 12).NumberFormatLocal = "0.00%"
.Cells(i, 13).Value = 工作表6.Cells(3, 4).Value '董監持股%
' .Cells(i, 13).NumberFormatLocal = "0.00%"
Debug.Print v
Next
End With
With ie 'IE視窗最大化
Application.WindowState = xlMaximized
.Height = Application.Height
.Width = Application.Width
.Quit
End With
End Sub
Public Function MyFile(v As Integer, i As Integer)
' 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
.Range("E" & v & ":M" & v) = ""
' .Range("E2").CurrentRegion = "" '清除工作表1,年度範圍
v = .Cells(i, 1).Value
GetDividend (v)
GetClosePrice (v)
GetIncome (v)
GetBalance (v)
GetShareholding (v)
.Cells(i, 5).Value = 工作表2.Cells(5, 2).Value
.Cells(i, 6).Value = 工作表2.Cells(5, 3).Value
.Cells(i, 7).Value = 工作表3.Cells(2, 8).Value
.Cells(i, 8).Value = .Cells(i, 5).Value / .Cells(i, 7).Value '現金殖利率
On Error Resume Next
' .Cells(i, 8).NumberFormatLocal = "0.00%"
.Cells(i, 9).Value = 工作表4.Cells(66, 2).Value / 工作表5.Cells(94, 2).Value 'ROE%
On Error Resume Next
.Cells(i, 10).Value = 工作表3.Cells(4, 2).Value '本益比
.Cells(i, 11).Value = 工作表3.Cells(12, 4).Value '股價淨值比
.Cells(i, 12).Value = 工作表3.Cells(11, 4).Value '負債比%
' .Cells(i, 12).NumberFormatLocal = "0.00%"
.Cells(i, 13).Value = 工作表6.Cells(3, 4).Value '董監持股%
' .Cells(i, 13).NumberFormatLocal = "0.00%"
End With
With ie 'IE視窗最大化
Application.WindowState = xlMaximized
.Height = Application.Height
.Width = Application.Width
.Quit
End With
End Function
Private Sub GetDividend(ByVal ss As String) '取股利網頁
Dim strText As String
Dim i As Integer, j As Integer, xTable As Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zcc/zcc_" & ss & ".djhtm", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set xTable = .all.tags("table")(2)
With 工作表2
.Cells.Clear
For i = 0 To xTable.Rows.Length - 1
For j = 0 To xTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Private Sub GetClosePrice(ByVal ss As String) ' 取基本資料
Dim strText As String
Dim i As Integer, j As Integer, xTable As Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zca/zca_" & ss & ".djhtm", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set xTable = .all.tags("table")(2)
With 工作表3
.Cells.Clear
For i = 0 To xTable.Rows.Length - 1
For j = 0 To xTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Private Sub GetIncome(ByVal ss As String) '取損益表(年表)網頁
Dim strText As String
Dim i As Integer, j As Integer, xTable As Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_" & ss & ".djhtm", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set xTable = .all.tags("table")(2)
With 工作表4
.Cells.Clear
For i = 0 To xTable.Rows.Length - 1
For j = 0 To xTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Private Sub GetBalance(ByVal ss As String) '取資產負債表(年表)網頁
Dim strText As String
Dim i As Integer, j As Integer, xTable As Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://kgieworld.moneydj.com/z/zc/zcp/zcpb/zcpb_" & ss & ".djhtm", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set xTable = .all.tags("table")(2)
With 工作表5
.Cells.Clear
For i = 0 To xTable.Rows.Length - 1
For j = 0 To xTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Private Sub GetShareholding(ByVal ss As String) '取董監持股網頁
Dim strText As String
Dim i As Integer, j As Integer, xTable As Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zcj/zcj_" & ss & ".djhtm", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set xTable = .all.tags("table")(3)
With 工作表6
.Cells.Clear
For i = 0 To xTable.Rows.Length - 1
For j = 0 To xTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Function BinToStr(arrBin, strChrs)
With CreateObject("ADODB.Stream")
.Type = 2
.Open
.Writetext arrBin
.Position = 0
.Charset = strChrs
BinToStr = .ReadText
.Close
End With
End Function

複製代碼