VBA入門實作基礎篇：抓財務比率季表 +進階篩選，

聲明：請大家尊重網路資源，勿濫用內文教學內容。

這篇可以說是以前作品的延伸版，前些日子有網友在以前的部落格留言，問關於這方面問題，所以寫一寫當作分享跟紀錄。

架構：

要設定3頁，3個ACRIVEX命令按鈕。

圖1.命令按鈕在那?

說明：

1.先點選設計模式。

2.在點選小紅框的命令按鈕，然後隨意於工作表上點選後，在按住滑鼠左鍵控制大小即可。(參圖2)

P.S因為小編有設定標題的習慣，程式碼預設是從第2列開始抓資料歐。

圖2.按鈕參考

第一頁名稱隨意(可以參考圖1做航別設定)，先設定1個ACRIVEX命令按鈕。

之後設定第二頁工作表為TEMP，第三頁工作表為總表。

大概參圖3這樣子

圖3.工作表名稱設定

第二頁設定2個按鈕並設定欄位名稱，如圖4。

圖4.總表設定

說明：要改按鈕顯示的標籤名稱，點選開發人員>屬性之後再對話框做修改。

圖5.屬性修改

接下來是程式部分

有4個副程式要處理，副程式1請先按以下5步驟做處理：

1.鍵盤上的ALT+F11這兩個鍵同時按下，出現如圖6.

圖6.

2.點選專案總管：

圖7.

3.新增模組：

圖8.新增模組

圖9.專案管理確認

4.複製CODE：

	Sub 財務比率季表_DOWNLOAD() '財務比率季表
	Dim DATA(20, 7) As Variant
	Add = 0
	Sheets("TEMP").Range("a:I").Clear '.Clear 'Range("a" & I)
	Sheets("總表").Range("a5:J2000").Clear
	Sheets("總表").Range("2:2").Clear
	' If (Format(Now(), "0") - DA) <= 7 Then
	For i = 2 To 20 Step 1
	STOCK_ID = ActiveSheet.Range("a" & i)
	If STOCK_ID <> "" Then
	'財務比率季表
	head = "" '網站路徑自設
	STOCK_ID = ActiveSheet.Range("a" & i)
	'htm = ".djhtm"
	財務比率季表 = head & STOCK_ID '& htm
	Call IFRS財報("TEMP", 財務比率季表)
	DATA(i - 2, 0) = STOCK_ID
	DATA(i - 2, 1) = Sheets("TEMP").Range("B" & 12) '營業利益率 12
	DATA(i - 2, 2) = Sheets("TEMP").Range("B" & 13) '稅前淨利率 13
	DATA(i - 2, 3) = Sheets("TEMP").Range("B" & 14) '稅後淨利率 14
	DATA(i - 2, 4) = Sheets("TEMP").Range("B" & 50) '流動比率 50
	DATA(i - 2, 5) = Sheets("TEMP").Range("B" & 51) '速動比率 51
	DATA(i - 2, 6) = Sheets("TEMP").Range("B" & 53) '負債比率％ 53
	DATA(i - 2, 7) = Sheets("TEMP").Range("B" & 62) '存貨週轉率(次) 62
	Add = Add + 1
	End If
	Next i
	Sheets("總表").Range("a5:H" & Add + 6) = DATA
	MsgBox "OK"
	End Sub

view raw gistfile1.txt hosted with ❤ by GitHub

複製卷_財務比率季表_DOWNLOAD 的CODE，點選剛剛產生的模組1，點開後貼上即可。

圖10.CODE貼在模組1

5.副程式1網址設定：

圖11.副程式網址設定段落

圖12.網址取得(紅框處)

說明：透過 IE瀏覽器，在某卷商的網站中，找到財務分析比率季表，點選滑鼠左鍵，選內容會跳出如圖10的對話框，再複製紅框標記處即可。

補充：請大家尊重網路資源，恕不提供卷商網址，僅做教學參考。

https://XXXXXXX.com/z/zc/zcr/zcr.djhtm?a=XXXX

圖13.副程式1補上網址。

VBA CODE流程:

副程式1：

圖14.副程式1：卷_財務比率季表_DOWNLOAD流程

副程式2~4：

	Sub IFRS財報(SHEET_NAME, E) '針對IFRS版財報新增的模組
	On Error GoTo LINE1:
	Dim web, Url, webdata
	Sheets(SHEET_NAME).Cells.Clear '清除之前資料
	Url = E
	Set web = CreateObject("Microsoft.XMLHTTP")
	web.Open "get", Url, False
	web.send
	webdata = Split(web.responsetext, vbLf)
	b = Filter(webdata, "個股代碼錯誤")
	bv = Filter(webdata, "t4t1")
	If UBound(bv) > 0 Then
	ReDim S_DATA(UBound(bv) * 10, 8) As Variant
	End If
	A = 0
	If UBound(b) < 0 Then
	For i = 0 To UBound(webdata) - 1 Step 1
	If InStr(webdata(i), "<td class=" & Chr(34) & "t2" & Chr(34) & ">") > 0 Then
	item1 = LTrim(webdata(i))
	'item1 = Split(item1, "</td>")
	For S = 0 To 9 Step 1
	If Len(webdata(i + S)) < 30 And Len(webdata(i + S)) > 6 Then
	n2 = Split(webdata(i + S), "</td>")
	n3 = 1
	If UBound(n2) > 0 Then
	X = Len(n2(0))
	For v = 0 To X Step 1
	A1 = Mid(n2(0), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, S) = Mid(n2(0), n3, X - n3 + 1)
	webdata(i + S) = ""
	Exit For
	End If
	Next v
	End If
	End If
	Next S
	A = A + 1
	End If
	If InStr(webdata(i), "t4t1") > 0 And InStr(webdata(i + 1), "t3n1") > 0 Then
	item1 = LTrim(webdata(i))
	item1 = Split(item1, "</td>")
	If UBound(item1) >= 2 Then
	n3 = 1
	X = Len(item1(0))
	For v = 0 To X Step 1
	A1 = Mid(item1(0), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, 0) = Mid(item1(0), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	n3 = 1
	X = Len(item1(1))
	For v = 0 To X Step 1
	A1 = Mid(item1(1), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, 1) = Mid(item1(1), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	End If
	For S = 0 To 8 Step 1
	n2 = Split(webdata(i + S), "</td>")
	n3 = 1
	If UBound(n2) > 0 Then
	X = Len(n2(0))
	For v = 0 To X Step 1
	A1 = Mid(n2(0), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, S) = Mid(n2(0), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	End If
	' End If
	Next S
	webdata(i) = ""
	A = A + 1
	End If
	If InStr(webdata(i), "t4t1") > 0 And InStr(webdata(i + 1), "t3r1") > 0 Then
	item1 = LTrim(webdata(i))
	item1 = Split(item1, "</td>")
	If UBound(item1) >= 2 Then
	n3 = 1
	X = Len(item1(0))
	For v = 0 To X Step 1
	A1 = Mid(item1(0), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, 0) = Mid(item1(0), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	n3 = 1
	X = Len(item1(1))
	For v = 0 To X Step 1
	A1 = Mid(item1(1), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, 1) = Mid(item1(1), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	End If
	For S = 0 To 8 Step 1
	n2 = Split(webdata(i + S), "</td>")
	n3 = 1
	If UBound(n2) > 0 Then
	X = Len(n2(0))
	For v = 0 To X Step 1
	A1 = Mid(n2(0), n3, 1)
	n3 = n3 + 1
	If A1 = ">" Then
	S_DATA(A, S) = Mid(n2(0), n3, X - n3 + 1)
	Exit For
	End If
	Next v
	End If
	' End If
	Next S
	webdata(i) = ""
	A = A + 1
	End If
	Next i
	Else
	End If
	If UBound(b) < 0 Then
	Sheets(SHEET_NAME).Range("a3:i" & A + 2) = S_DATA
	Sheets(SHEET_NAME).Range("a3:i" & A + 2).Replace "N/A", "-"
	Else
	Sheets("工作表1").Range("a1") = SHEET_NAME & "："
	Sheets("工作表1").Range("b1") = "個股代碼錯誤"
	End If
	Exit Sub
	LINE1:
	End Sub

view raw gistfile1.txt hosted with ❤ by GitHub

	Sub C_2()'進階篩選
	Dim myRange1 As Range, myRange2 As Range, myRange3 As Range, myRange4 As Range, myCell As Range, myCell2 As Range
	Set myRange1 = Range("A5:I2000").CurrentRegion '指定資料區域
	Set myRange2 = Range("b1:H2") '條件區域
	' If (Format(Now(), "0") - DA) <= 7 Then
	For Each myCell In myRange2.Cells
	If myCell.Value <> "" Then
	A = myCell.Address
	X = Split(A, "$")
	If ActiveSheet.Range(X(1) & X(2) + 1) <> "" Then
	If TEX <> "" Then
	TEX = TEX & "," & X(1) & X(2) & ":" & X(1) & X(2) + 1
	TEX1 = TEX1 + 1
	End If
	If TEX = "" Then
	TEX = X(1) & X(2) & ":" & X(1) & X(2) + 1
	TEX1 = TEX1 + 1
	End If
	End If
	End If
	Next
	Set myRange3 = Range(TEX)
	g = 0
	For Each myCell In myRange3.Cells
	ActiveSheet.Cells(1 + h, 50 + g) = myCell
	h = h + 1
	If h = 2 Then
	g = g + 1
	h = 0
	End If
	Next
	Set myRange4 = Range(ActiveSheet.Cells(1, 50), ActiveSheet.Cells(2, 50 + TEX1 - 1))
	myRange1.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=myRange4
	' For Each myCell In myRange4.Cells
	' myCell.Clear '刪除條件區域
	' Next
	Set myRange1 = Nothing
	Set myRange2 = Nothing
	End Sub
	Sub C_3()'進階篩選與復原
	Dim ws As Worksheet
	Set ws = ThisWorkbook.ActiveSheet
	With ws
	If .FilterMode Then
	.ShowAllData
	End If
	End With
	Set ws = Nothing
	End Sub

view raw gistfile1.txt hosted with ❤ by GitHub

比照前面的"4.複製CODE：" 操作即可

接著，在總表的工作表中新增2個ACTIVEX命令按鈕，如圖5.

針對"篩選"按鈕如下編輯內容

CALL C2

針對"取消篩選"按鈕如下編輯內容

CALL C3

圖15.按鈕的VBA CODE

可以開始測試瞜。