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

Option Explicit
Sub 股利股息()
Dim Sh As Worksheet, i As Integer
On Error Resume Next '不理會程式上的錯誤,程式繼續執行下去
Set Sh = Sheets("股利股息") '沒有 Sheets("股利股息")時有程式上的錯誤]
On Error GoTo 0 '程式停止處理錯誤,程式執行上有錯誤發生會終止.
If Sh Is Nothing Then '沒有 Sheets("股利股息")時 Sh Is Nothing
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "股利股息"
Set Sh = Sheets("股利股息")
End If
With Sh ' Worksheets("股利股息").Select
.UsedRange.Clear
.Range("A1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
.Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
.Range("B2").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
End With
For i = 10 To Sheets("個股資料").Range("B10").End(xlDown).Row
Sh.Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(11) = Worksheets("個股資料").Range("C" & i).Value ' '將A欄位填入股票名稱，連續填寫11列
With Sh.QueryTables.Add(Connection:= _
"URL;https://tw.stock.yahoo.com/d/s/dividend_" & Sheets("個股資料").Range("B" & i) & ".html", Destination:=Sh.Cells(Rows.Count, 2).End(xlUp).Offset(1))
.Name = "0000000"

複製代碼

Sub ROE()
For i = 10 To Sheets("個股資料").Range("B281").End(xlDown).Row
Worksheets("ROE總表").Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
Worksheets("ROE").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://stockchannelnew.sinotrade.com.tw/z/zc/zcr/zcra/zcra_" & Sheets("個股資料").Range("B" & i) & ".djhtm", Destination:=Range("B1"))
.Name = "0000000"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("C1:C500").Find("股東權益報酬率").Select
Range(Selection, Selection.End(xlToRight)).Copy
Worksheets("ROE總表").Select
Worksheets("ROE總表").Range("B1").Select
ActiveCell.End(xlDown).Select
lastrow = ActiveCell.Row
ActiveSheet.Paste Destination:=Worksheets("ROE總表").Range("b" & lastrow + 1)
Worksheets("ROE總表").Range("A" & lastrow + 1).Value = Worksheets("個股資料").Range("C" & i).Value
Worksheets("ROE").Select
Worksheets("ROE").Range("B1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Delete
Next
End Sub

複製代碼

For i = 10 To Sheets("個股資料").Range("B281").End(xlDown).Row
Worksheets("ROE總表").Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
Worksheets("ROE總表").Range("B2:J2") = Array("期別", "104", "103", "102", "101", "100", "99", "98", "97")
'是少了這裡嗎?

複製代碼

Sub ROE_1()
[ROE總表!B1].Value = String(52, "+")
For i = 10 To [個股資料!B281].End(xlDown).Row
With Sheets("ROE").QueryTables.Add(Connection:= _
"URL;http://stockchannelnew.sinotrade.com.tw/z/zc/zcr/zcra/zcra_" & _
[個股資料!B1].Cells(i, 1) & ".djhtm", Destination:=[ROE!B1])
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
Dim xF As Range, xE As Range
Set xF = [ROE!C1:C500].Find("股東權益報酬率")
If Not xF Is Nothing Then
Set xE = [ROE總表!B1].End(xlDown)(2)
xE.Select
Range(xF, xF.End(xlToRight)).Copy xE
xE(1, 0) = Sheets("個股資料").Range("C" & i)
End If
Sheets("ROE").UsedRange.Clear
Next
End Sub

複製代碼

Range("C1:C500").Find("股東權益報酬率").Select

複製代碼

Option Explicit
Sub Ex_ROE()
Dim Sh(1 To 3) As Worksheet, Rng As Range, i As Integer
Set Sh(1) = Sheets("個股資料")
Set Sh(2) = Worksheets("ROE總表")
Set Sh(3) = Worksheets("ROE")
'***執行本程式碼一次後,可刪除掉兩行星號間的程式碼**
'*************************************
'刪除 ROE 頁上QueryTables及 QueryTables.Add所新增的名稱
'QueryTable過多,名稱過多也是檔案膨大的原因之ㄧ
With Sh(3)
For i = .Names.Count To 1 Step -1
.Names(i).Delete
Next
.UsedRange.Clear
For i = .QueryTables.Count To 1 Step -1
.QueryTables(i).Delete
Next
End With
'******************************
With Sh(2)
.UsedRange.Clear
.Range("B1") = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
.Range("B2:J2") = Array("期別", "104", "103", "102", "101", "100", "99", "98", "97")
.Activate
End With
For i = 10 To Sh(1).Range("B281").End(xlDown).Row
If Sh(1).Range("B" & i) <> "" Then '非空白儲存格
With Sh(3).QueryTables.Add(Connection:= _
"URL;http://stockchannelnew.sinotrade.com.tw/z/zc/zcr/zcra/zcra_" & Sh(1).Range("B" & i) & ".djhtm", Destination:=Sh(3).Range("B1"))
'.Name = "0000000" '名稱以數字開頭,會自動加上"_" 為 "_0000000"
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With Sh(3).QueryTables(1)
Application.StatusBar = i - 9 & " - " & .ResultRange.Range("b2") & " 股東權益報酬率完成"
If .ResultRange.Rows.Count > 5 Then
Sh(2).Range("b1").End(xlDown).Offset(1, -1).Resize(, .ResultRange.Columns.Count) = .ResultRange.Rows(16).Value
Sh(2).Range("b1").End(xlDown).Offset(, -1) = Sh(1).Range("C" & i)
Sh(2).Range("b1").End(xlDown).Offset(, -1).Activate
Else
Sh(2).Range("b1").End(xlDown).Offset(1) = "查無 " & .ResultRange.Range("b2") & " 財務比率表資料(合併年表)"
End If
.ResultRange.Clear '清除匯入外部的資料
Sh(3).Names(.Name).Delete '刪除自動新增的名稱
.Delete '刪除 QueryTable 物件
End With
End If
Next
End Sub

複製代碼