- 帖子
- 161
- 主題
- 26
- 精華
- 0
- 積分
- 187
- 點名
- 0
- 作業系統
- xp
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 來自
- TW
- 註冊時間
- 2011-1-2
- 最後登錄
- 2022-2-16
|
8#
發表於 2021-11-18 20:37
| 只看該作者
Option Explicit
Dim ie As Object '模組最頂端 Dim 供這模組的程序使用的變數
Sub AllFile()
Dim i As Integer, v, Y As Integer, S As String
Dim z As Integer
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
With ie '縮小IE視窗
.Visible = True
.Width = 5
.Height = 5
End With
With 工作表1
Dim AR
AR = .Range("C1:J1")
.Range("C:J") = ""
.Range("C1:J1") = AR
z = 0
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
v = .Cells(i, 1).Value
GetDividend (v)
.Cells(i, 3).Resize(1, 7).Value = 工作表2.Cells(3, 1).Resize(1, 7).Value
If 工作表2.Cells(3, 5).Value > 0 Then
.Cells(i, 10).Value = 1
z = z + 1
Else
.Cells(i, 10).Value = 0
End If
If 工作表2.Cells(3, 5).Value > 0 And 工作表2.Cells(4, 5).Value > 0 And 工作表2.Cells(5, 5).Value > 0 Then 'K(營收連3個月正成長)
.Cells(i, 11).Value = 1
Else
.Cells(i, 11).Value = 0
End If
Next
' MsgBox "共有" & z & "家正成長"
.Cells(1, 10).Value = "去年同期年增率" & Split(Date, "/")(1) - 1 & "月份" & .Range("A" & .Rows.Count).End(xlUp).Row & "家共有" & z & "家正成長"
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 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/zch/zcha_" & 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
If .Range("a2") = "" Then .Range("a1:g2").Delete Shift:=xlUp '修改加這行摻考 http://forum.twbts.com/thread-23487-1-1.html
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 |
|
