把Acer_kewei 的表格+網址，合併成一個檔案，早上臨時寫，有bug請無視
表單排版超隨便，也請無視
如果有人要重排一個表單給我這個美術白癡，非常歡迎，我再修改
按看看，1次 or 2次
'===================================
'範例說明：
'610樓的表格+613樓的程式=>合併
'開出來的表單，可拉到旁邊放著，不影響excel操作
'程式內的股票代號，跟工作表中的同步，如果有改變會自動修改表單
'===================================
'thisworkbook
Private Sub Workbook_Open()
Sheets("acc").Cells.Clear
Sheets("股價漲跌資料表").Cells.Clear
Sheets("股利政策").Cells.Clear
Call get_Q_Y
' If ((Not Not Q) = 0) Or ((Not Not Y) = 0) Then
' Debug.Print "network error"
' End If
'UserForm1.Show 0
End Sub
'userform1===================================
Private Sub CommandButton1_Click()
Dim url As String, url_a As String
If ListBox3.List(0) = "error" Then
MsgBox "網路異常，請按手動更新，重試一次"
CommandButton5.Visible = True
Exit Sub
End If
If TextBox1.Text <> "" Then
url = "https://goodinfo.tw/StockInfo/StockFinDetail.asp?STEP=DATA&STOCK_ID=" & TextBox1.Text & _
"&RPT_CAT=" & Split(UserForm1.ListBox2.List(UserForm1.ListBox2.ListIndex), ",")(1) & _
"&QRY_TIME=" & Replace(UserForm1.ListBox3.List(UserForm1.ListBox3.ListIndex, 0), "Q", "")
url_a = "https://goodinfo.tw/StockInfo/StockFinDetail.asp?RPT_CAT=" & _
Split(UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex), ",")(1) & _
"&STOCK_ID=" & TextBox1.Text
Call getpost(url, url_a, "acc")
Else
MsgBox "請在清單選擇或在textbox輸入股票代號"
End If
End Sub
Private Sub CommandButton2_Click()
Dim url As String, url_a As String
If ListBox3.List(0) = "error" Then
MsgBox "網路異常，請按手動更新，重試一次"
CommandButton5.Visible = True
Exit Sub
End If
If TextBox1.Text <> "" Then
url = "https://goodinfo.tw/StockInfo/ShowK_Chart.asp?STOCK_ID=" & TextBox1.Text & _
"&CHT_CAT2=DATE&STEP=DATA&PERIOD=" & Split(UserForm1.ListBox4.List(UserForm1.ListBox4.ListIndex), ",")(1)
url_a = "https://goodinfo.tw/StockInfo/ShowK_Chart.asp?STOCK_ID=" & TextBox1.Text & "&CHT_CAT2=DATE"
Call getpost(url, url_a, "股價漲跌資料表")
Else
MsgBox "請在清單選擇或在textbox輸入股票代號"
End If
End Sub
Private Sub CommandButton3_Click()
Dim url As String, url_a As String
If ListBox3.List(0) = "error" Then
MsgBox "網路異常，請按手動更新，重試一次"
CommandButton5.Visible = True
Exit Sub
End If
If TextBox1.Text <> "" Then
url = "https://goodinfo.tw/StockInfo/ShowK_Chart.asp?STOCK_ID=" & TextBox1.Text & "&CHT_CAT2=MONTH"
url_a = ""
Call getpost(url, url_a, "股價漲跌資料表")
Else
MsgBox "請在清單選擇或在textbox輸入股票代號"
End If
End Sub
Private Sub CommandButton4_Click()
Dim url As String, url_a As String
If ListBox3.List(0) = "error" Then
MsgBox "網路異常，請按手動更新，重試一次"
CommandButton5.Visible = True
Exit Sub
End If
If TextBox1.Text <> "" Then
url = "https://goodinfo.tw/StockInfo/StockDividendPolicy.asp?STOCK_ID=" & TextBox1.Text
url_a = ""
Call getpost(url, url_a, "股利政策")
Else
MsgBox "請在清單選擇或在textbox輸入股票代號"
End If
End Sub
Private Sub CommandButton5_Click()
Call get_Q_Y
If ((Not Not Y) = 0) Or ((Not Not Q) = 0) Then
Debug.Print "network error"
Else
CommandButton5.Visible = False
ListBox3.List = listdata(6)
End If
ListBox1.ListIndex = 0
ListBox2.ListIndex = 0
ListBox3.ListIndex = 0
ListBox4.ListIndex = 0
End Sub
Private Sub ListBox1_Click()
With ListBox1
ListBox2.List = listdata(ListBox1.ListIndex + 1)
ListBox2.ListIndex = 0
End With
'Call ListBox2_Click
End Sub
Private Sub ListBox2_Click()
With ListBox3
If InStr(ListBox2.List(ListBox2.ListIndex), "季") = 0 Then
.List = listdata(5)
Else
.List = listdata(6)
End If
.ListIndex = 0
End With
End Sub
Private Sub ListBox5_Click()
Select Case ListBox5.List(ListBox5.ListIndex)
Case Is = "台灣50"
ListBox6.List = Sheets("台灣50").Range("a4:b54").Value
Case Is = "中型100"
ListBox6.List = Sheets("中型100").Range("a4:b101").Value
Case Is = "自訂"
If Sheets("自訂").Range("A1").CurrentRegion.Rows.Count >= 2 Then
ListBox6.List = Sheets("自訂").Range("a2:b" & Sheets("自訂").Range("A1").CurrentRegion.Rows.Count).Value
End If
End Select
ListBox6.ListIndex = 0
End Sub
Private Sub ListBox6_Click()
TextBox1.Text = UserForm1.ListBox6.List(UserForm1.ListBox6.ListIndex, 0)
End Sub
Private Sub UserForm_Initialize()
Call addlistbox_new
ListBox1.ListIndex = 0
ListBox2.ListIndex = 0
ListBox3.ListIndex = 0
ListBox4.ListIndex = 0
ListBox5.ListIndex = 2
ListBox6.ListIndex = 0
End Sub
'module1================================
Public Q(), Y()
Sub open_form()
If UserForm1.Visible = True Then
UserForm1.Hide
Else
UserForm1.Show 0
End If
' Call get_Q_Y
' UserForm1.Show 0
End Sub
Sub get_Q_Y() '季別、年度
Dim HTMLsourcecode As Object, Getxml As Object, Get_Q, Get_Y, i As Integer, j As Integer
Set HTMLsourcecode = CreateObject("htmlfile")
Set Getxml = CreateObject("WinHttp.WinHttpRequest.5.1")
url = "https://goodinfo.tw/StockInfo/StockFinDetail.asp?RPT_CAT=BS_M_QUAR&STOCK_ID=2412"
url_a = "https://goodinfo.tw/StockInfo/StockFinDetail.asp?STEP=DATA&STOCK_ID=2412&RPT_CAT=BS_M_YEAR&QRY_TIME=20184"
On Error Resume Next
For i = 1 To 2
With Getxml
.Open "POST", choose(i, url, url_a), False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
If i = 2 Then .setRequestHeader "Referer", url
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
If InStr(HTMLsourcecode.body.innertext, "查 無 資 料 !!") > 0 Then
'MsgBox "查無資料"
Exit Sub
End If
If i = 1 Then
Set Get_Q = HTMLsourcecode.getelementbyid("QRY_TIME")
Debug.Print Get_Q.Length
ReDim Q(Get_Q.Length - 1)
For j = 0 To Get_Q.Length - 1
Q(j) = Get_Q(j).innertext
Next j
Else
Set Get_Y = HTMLsourcecode.getelementbyid("QRY_TIME")
Debug.Print Get_Y.Length
ReDim Y(Get_Y.Length - 1)
For j = 0 To Get_Y.Length - 1
Y(j) = Left(Get_Y(j).innertext, 4)
Next j
End If
End With
Next i
Set HTMLsourcecode = Nothing
Set Getxml = Nothing
Set Get_Q = Nothing
Set Get_Y = Nothing
End Sub
Sub getpost(url As String, url_a As String, n As String)
Dim HTMLsourcecode As Object, Clipboard As Object, Getxml As Object
Set HTMLsourcecode = CreateObject("htmlfile")
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set Getxml = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error Resume Next
With Getxml
.Open "POST", url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
If url_a <> "" Then .setRequestHeader "Referer", url_a
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
If InStr(HTMLsourcecode.body.innertext, "查無股利政策資訊") > 0 Then
MsgBox "查無股利政策資訊"
Exit Sub
End If
If InStr(HTMLsourcecode.body.innertext, "查 無 資 料 !!") > 0 Then
MsgBox "查無資料"
Exit Sub
End If
If InStr(HTMLsourcecode.body.innertext, "查無股價相關資料!!") > 0 Then
MsgBox "查無股價相關資料!!"
Exit Sub
End If
If n <> "股利政策" Then
With Clipboard
If n = "acc" Then .SetText HTMLsourcecode.getelementbyid("divFinDetail").innerhtml
If n = "股價漲跌資料表" Then .SetText HTMLsourcecode.getelementbyid("divPriceDetail").innerhtml
.PutInClipboard
End With
End If
With Sheets(n)
.Select
.Cells.Clear
.Cells(2, 1).Select
If n = "股利政策" Then
Clipboard.SetText HTMLsourcecode.all.tags("table")(10).innerhtml
Clipboard.PutInClipboard
.PasteSpecial NoHTMLFormatting:=True
Clipboard.SetText HTMLsourcecode.getelementbyid("divDetail").innerhtml
Clipboard.PutInClipboard
.Cells(15, 1).Select
.PasteSpecial NoHTMLFormatting:=True
Else
.PasteSpecial NoHTMLFormatting:=True
End If
'標題
If n = "acc" Then
.Cells(1, 1) = "股票代號：" & UserForm1.TextBox1.Text & _
"(" & Trim(Split(UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex), ",")(0)) & ")" & _
"(" & Trim(Split(UserForm1.ListBox2.List(UserForm1.ListBox2.ListIndex), ",")(0)) & ")" & _
"(" & UserForm1.ListBox3.List(UserForm1.ListBox3.ListIndex) & ")"
Else
If n = "股價漲跌資料表" Then
If Right(url, 5) = "MONTH" Then
.Cells(1, 1) = "股票代號：" & UserForm1.TextBox1.Text & "(月K)"
Else
.Cells(1, 1) = "股票代號：" & UserForm1.TextBox1.Text & _
"(資料範圍：" & Trim(Split(UserForm1.ListBox4.List(UserForm1.ListBox4.ListIndex), ",")(0)) & ")"
End If
Else
.Cells(1, 1) = "股票代號：" & UserForm1.TextBox1.Text
End If
End If
.Cells(1, 1).Font.Bold = True
.Cells(1, 1).Font.Color = -16776961
.Cells(1, 1).Font.Size = 18
.Cells(2, 1).Select
End With
End With
'財務比率表(整理)
If Trim(Split(UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex), ",")(0)) = "財務比率表" Then
For i = Sheets("acc").Range("A1").CurrentRegion.Rows.Count - 2 To 2 Step -1
If Sheets("acc").Cells(i, 2) = "" Then
Rows(i & ":" & i).Delete Shift:=xlUp
End If
Next i
End If
Set HTMLsourcecode = Nothing
Set Clipboard = Nothing
Set Getxml = Nothing
End Sub
Function listdata(choose)
Select Case choose
Case 0
listdata = Array("資產負債表" & Space(30) & ",BS_M_QUAR", "損益表" & Space(30) & ",IS_M_QUAR_ACC", "現金流量表" & Space(30) & ",CF_M_QUAR_ACC", "財務比率表" & Space(30) & ",XX_M_QUAR_ACC")
Case 1
listdata = Array("合併報表 – 單季" & Space(30) & ",BS_M_QUAR", "合併報表 – 年度" & Space(30) & ",BS_M_YEAR", "個別報表 – 單季" & Space(30) & ",BS_QUAR", "個別報表 – 年度" & Space(30) & ",BS_YEAR")
Case 2
listdata = Array("合併報表 – 單季" & Space(30) & ",IS_M_QUAR", "合併報表 – 累季" & Space(30) & ",IS_M_QUAR_ACC", "合併報表 – 年度" & Space(30) & ",IS_M_YEAR", "合併報表 – 近四季" & Space(30) & ",IS_M_Y4Q", "個別報表 – 單季" & Space(30) & ",IS_QUAR", "個別報表 – 累季" & Space(30) & ",IS_QUAR_ACC", "個別報表 – 年度" & Space(30) & ",IS_YEAR", "個別報表 – 近四季" & Space(30) & ",IS_Y4Q")
Case 3
listdata = Array("合併報表 – 單季" & Space(30) & ",CF_M_QUAR", "合併報表 – 累季" & Space(30) & ",CF_M_QUAR_ACC", "合併報表 – 年度" & Space(30) & ",CF_M_YEAR", "合併報表 – 近四季" & Space(30) & ",CF_M_Y4Q", "個別報表 – 單季" & Space(30) & ",CF_QUAR", "個別報表 – 累季" & Space(30) & ",CF_QUAR_ACC", "個別報表 – 年度" & Space(30) & ",CF_YEAR", "個別報表 – 近四季" & Space(30) & ",CF_Y4Q")
Case 4
listdata = Array("合併報表 – 單季" & Space(30) & ",XX_M_QUAR", "合併報表 – 累季" & Space(30) & ",XX_M_QUAR_ACC", "合併報表 – 年度" & Space(30) & ",XX_M_YEAR", "合併報表 – 近四季" & Space(30) & ",XX_M_Y4Q", "個別報表 – 單季" & Space(30) & ",XX_QUAR", "個別報表 – 累季" & Space(30) & ",XX_QUAR_ACC", "個別報表 – 年度" & Space(30) & ",XX_YEAR", "個別報表 – 近四季" & Space(30) & ",XX_Y4Q")
Case 5
If ((Not Not Y) = 0) Then
listdata = Array("error")
Else
listdata = Application.Transpose(Y)
End If
Case 6
If ((Not Not Q) = 0) Then
listdata = Array("error")
Else
listdata = Application.Transpose(Q)
End If
End Select
End Function
Sub addlistbox_new()
With UserForm1.ListBox1
.List = listdata(0)
End With
With UserForm1.ListBox2
.List = listdata(1)
End With
With UserForm1.ListBox3
.List = listdata(6)
End With
With UserForm1.ListBox4
.List = Array("三個月" & Space(30) & ",90", "六個月" & Space(30) & ",180", "一年" & Space(30) & ",365")
End With
With UserForm1.ListBox5
.List = Array("台灣50", "中型100", "自訂")
End With
With UserForm1.ListBox6
.List = Sheets("台灣50").Range("a4:b54").Value
End With
End Sub
Function convertraw(rawdata)
Dim rawstr
Set rawstr = CreateObject("adodb.stream")
With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "utf-8"
convertraw = .ReadText
.Close
End With
Set rawstr = Nothing
End Function
Sub get_0050持股明細()
Dim url As String, HTMLsourcecode As Object, Getxml As Object, i As Integer, j As Integer, Update_Day As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
url = "https://www.moneydj.com/ETF/X/Basic/Basic0007A.xdjhtm?etfid=0050.TW"
Application.ScreenUpdating = False
With Getxml
.Open "GET", url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.Send
HTMLsourcecode.body.innerhtml = .responsetext
With Sheets("台灣五十成份股比例")
.Cells.Clear
Update_Day = HTMLsourcecode.getelementbyid("ctl00_ctl00_MainContent_MainContent_sdate2").innertext
.Cells(1, 1) = "持股分佈 (依產業)" & "(" & Update_Day & ")"
Set Table = HTMLsourcecode.all.tags("table")(4).Rows
For i = 0 To Table.Length - 1
For j = 1 To Table(i).Cells.Length - 1
.Cells(i + 2, j) = Table(i).Cells(j).innertext
Next j
Next i
Update_Day = HTMLsourcecode.getelementbyid("ctl00_ctl00_MainContent_MainContent_sdate3").innertext
.Cells(1, 5) = "元大台灣卓越50基金-持股明細" & "(" & Update_Day & ")"
Set Table = HTMLsourcecode.all.tags("table")(5).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 2, j + 5) = Table(i).Cells(j).innertext
Next j
Next i
Set Table = HTMLsourcecode.all.tags("table")(6).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 2, j + 9) = Table(i).Cells(j).innertext
Next j
Next i
End With
End With
Call SetFormatCondition("台灣五十成份股比例", "H3")
Call SetFormatCondition("台灣五十成份股比例", "L3")
Set HTMLsourcecode = Nothing
Set Getxml = Nothing
Application.ScreenUpdating = True
End Sub
Sub get_0050()
Dim n As String, url As String, HTMLsourcecode As Object, Getxml As Object, i As Integer, check_color As String, check_Column As Integer
Set HTMLsourcecode = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
url = "https://tw.stock.yahoo.com/q/q?s="
n = "台灣50"
Application.ScreenUpdating = False
On Error Resume Next
i = 1
Do Until Sheets(n).Cells(2, i) = "成交"
i = i + 1
Loop
check_Column = i
If Format(Date, "yyyymmdd") <> Trim(Sheets(n).Cells(1, check_Column)) Then
Sheets(n).Columns(check_Column).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(n).Cells(1, check_Column) = Format(Date, "yyyymmdd")
Sheets(n).Columns(check_Column).AutoFit
Sheets(n).Cells(2, check_Column) = "成交"
End If
With Getxml
.Open "GET", "https://tw.stock.yahoo.com/", False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.Send
Sheets(n).Cells(3, check_Column) = Split(Split(.responsetext, "class=""dx"">")(1), "")(0)
End With
For i = 4 To 54
With Getxml
.Open "GET", url & Sheets(n).Cells(i, 1), False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.Send
HTMLsourcecode.body.innerhtml = .responsetext
With Sheets(n)
.Cells(i, check_Column) = HTMLsourcecode.all.tags("table")(2).Rows(1).Cells(2).innertext
check_color = HTMLsourcecode.all.tags("table")(2).Rows(1).Cells(5).innertext
If InStr(check_color, "▽") > 0 Or InStr(check_color, "▼") > 0 Then .Cells(i, check_Column).Font.Color = -11489280
If InStr(check_color, "△") > 0 Or InStr(check_color, "▲") > 0 Then .Cells(i, check_Column).Font.Color = -16776961
End With
End With
Next i
Set HTMLsourcecode = Nothing
Set Getxml = Nothing
Application.ScreenUpdating = True
End Sub
Sub get_100()
Dim n As String, url As String, HTMLsourcecode As Object, Getxml As Object, i As Integer, check_color As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
url = "https://tw.stock.yahoo.com/q/q?s="
n = "中型100"
Application.ScreenUpdating = False
On Error Resume Next
If Format(Date, "yyyymmdd") <> Trim(Sheets(n).Cells(1, 4)) Then
Sheets(n).Columns(4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(n).Cells(1, 4) = Format(Date, "yyyymmdd")
Sheets(n).Columns(4).AutoFit
Sheets(n).Cells(2, 4) = "成交"
End If
For i = 4 To 101
With Getxml
.Open "GET", url & Sheets(n).Cells(i, 1), False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.Send
HTMLsourcecode.body.innerhtml = .responsetext
With Sheets(n)
.Cells(i, 4) = HTMLsourcecode.all.tags("table")(2).Rows(1).Cells(2).innertext
check_color = HTMLsourcecode.all.tags("table")(2).Rows(1).Cells(5).innertext
If InStr(check_color, "▽") > 0 Or InStr(check_color, "▼") > 0 Then .Cells(i, 4).Font.Color = -11489280
If InStr(check_color, "△") > 0 Or InStr(check_color, "▲") > 0 Then .Cells(i, 4).Font.Color = -16776961
End With
End With
Next i
Set HTMLsourcecode = Nothing
Set Getxml = Nothing
Application.ScreenUpdating = True
End Sub
Sub SetFormatCondition(n As String, r As String)
Dim Crange As Range, C1 As FormatCondition, C2 As FormatCondition
Set Crange = Sheets(n).Range(r, Sheets(n).Range(r).End(xlDown))
Crange.FormatConditions.Delete
Crange.Font.Bold = True
Set C1 = Crange.FormatConditions.Add(xlCellValue, xlGreater, "=0")
C1.Font.Color = vbRed
Set C2 = Crange.FormatConditions.Add(xlCellValue, xlLess, "=0")
C2.Font.Color = -11489280
Set Crange = Nothing
End Sub
'===================================
'(20190407 20:20更新，感謝yuhuahsiao(632樓)提醒漏了一個表格沒下載
'請自行加入程式碼或重新下載檔案
附加壓縮檔: 201904/mobile01-152b62ba1b45ecbaa2af9cd8a578a92c.zip
