如何找到某一行業近5年的上市公司和財務數據？？？

01-16

（多圖預警）最省事的辦法是購買數據，這裡我不打廣告了，反正度娘一搜到處都有賣。

最好最省錢的辦法是自己編個程序上網採集，既能滿足個性化需求，又能提升自己的數據採集能力，數據分析能力，我已經這麼幹了，就是利用excel+vb做的，這是成果:

有了這些數據我就可以輕易的分析出某個行業的上市公司整體盈利水平變化，再配合國家統計局的數據，輕易就可以抓出一大堆圖表用來輔助論證行業分析結論，簡直不要太方便。

----------------------------2017年2月15日更新，說好的源代碼來了---------------------------------

用的就是vba，在任何安裝了office的電腦上都有，打開excel的宏，創建編輯就可以了，下面是我用到的幾個窗體、模塊、類、表單：

window1：

window2：

window3：

ps：好像這個window3是沒用的，用來做測試的……

我要貼代碼了，事先說明，我這套程序其實對用戶很不友好，有點難用，你們如果有編程基礎，可以參考一下，如果沒有一點基礎，想要拿來就用，可能還有點困難，畢竟這是我弄出來給自己用的程序。

另外，整個功能的實現採用的是流程式的編程，vba的面向對象功能實在是太屎了。

模塊1（代碼）：

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long "//調用

Dim au As String, fn As String

Sub a()

window1.Show

End Sub

window1（代碼）：

Dim au As String, fn As String, dh As String, a(4) As Long, b(11) As Long, c(11) As Long, d(2818, 1) As String

Dim bu As String

Private Sub an1_Click()

"14年年度 - 財報查詢 - 和訊股票 - 和訊網

au = "14年年度 - 財報查詢 - 和訊股票 - 和訊網"

fn = "f:data/test/2014- 1.html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

Sheets("sheet1").Select

Cells(2, 1) = 1

Cells(2, 6) = bz1

For i = 2 To 82

au = "http://datainfo.hexun.com/wholemarket/html/cbcx.aspx?data_type=fld_released_datepage=" + Str(i) + "tag=2report=2014-12-31"

fn = "f:data/test/2014-" + Str(i) + ".html"

Cells(i + 1, 1) = i

Cells(i + 1, 6) = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub an2_Click()

au = "13年年度 - 財報查詢 - 和訊股票 - 和訊網"

fn = "f:data/test/2013- 1.html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

Sheets("sheet1").Select

Cells(2, 1) = 1

Cells(2, 5) = bz1

For i = 2 To 120

au = "http://datainfo.hexun.com/wholemarket/html/cbcx.aspx?data_type=fld_released_datepage=" + Str(i) + "tag=2report=2013-12-31"

fn = "f:data/test/2013-" + Str(i) + ".html"

Cells(i + 1, 1) = i

Cells(i + 1, 5) = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub an3_Click()

au = "12年年度 - 財報查詢 - 和訊股票 - 和訊網"

fn = "f:data/test/2012- 1.html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

Sheets("sheet1").Select

Cells(2, 1) = 1

Cells(2, 4) = bz1

For i = 2 To 92

au = "http://datainfo.hexun.com/wholemarket/html/cbcx.aspx?data_type=fld_released_datepage=" + Str(i) + "tag=2report=2012-12-31"

fn = "f:data/test/2012-" + Str(i) + ".html"

Cells(i + 1, 1) = i

Cells(i + 1, 4) = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub CommandButton1_Click()

au = "11年年度 - 財報查詢 - 和訊股票 - 和訊網"

fn = "f:data/test/2011- 1.html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

Sheets("sheet1").Select

Cells(2, 1) = 1

Cells(2, 3) = bz1

For i = 2 To 78

au = "http://datainfo.hexun.com/wholemarket/html/cbcx.aspx?data_type=fld_released_datepage=" + Str(i) + "tag=2report=2011-12-31"

fn = "f:data/test/2011-" + Str(i) + ".html"

Cells(i + 1, 1) = i

Cells(i + 1, 3) = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub CommandButton10_Click()

window1.Hide

window2.Show

End Sub

Private Sub CommandButton11_Click()

Dim d1(500, 27) As String, px(500) As Integer, nian1 As Integer

Sheets("hyfx").Select

For i = 3 To 500 "給px數組賦值，該數組起到指針作用

px(i) = i

For i = 3 To 500 "將hyfx表單中的收入、凈利潤數據登記到d1數組中

If Cells(i, 2) = "" Then Exit For

For j = 2 To 27

d1(i, j) = Cells(i, j)

For i = 3 To 499 "將d1數組排序

For j = i + 1 To 500

If Val(d1(px(i), 27)) &< Val(d1(px(j), 27)) Then

temp1 = px(i)

px(i) = px(j)

px(j) = temp1

End If

If Cells(px(i), 2) = "" Then Exit For

Sheets("print").Select

nian1 = Cells(2, 2)

j = -3

hh = 6

For i = 3 To 500 "將d1數組中排序後的數據輸入到print表單中

If (i - 3) Mod hh = 0 Then "每hh行換一列輸出

j = j + 4

Cells(1, j) = "名稱"

Cells(1, j + 1) = "年度"

Cells(1, j + 2) = "凈利潤(萬元)"

Cells(1, j + 3) = "年收入(十萬元)"

End If

Cells(((i - 3) Mod hh) * 5 + 2, j) = d1(px(i), 2)

For k = 0 To 4

Cells(((i - 3) Mod hh) * 5 + 2 + k, j + 1) = nian1 + k "年度

Cells(((i - 3) Mod hh) * 5 + 2 + k, j + 2) = Val(d1(px(i), k * 5 + 5)) / 10000 "凈利潤

Cells(((i - 3) Mod hh) * 5 + 2 + k, j + 3) = Val(d1(px(i), k * 5 + 7)) / 100000 "年收入

If d1(px(i), 2) = "" Then Exit For

End Sub

Private Sub CommandButton12_Click()

Dim t1 As Date, t2 As Date, t3 As Date, szzs(7800, 1) As String

Sheets("dxzf").Select

Open "f:data est2999999.txt" For Input As #1

i = 0

Do While Not EOF(1)

Line Input #1, dh

If InStr(1, Left(dh, 11), "/") &> 0 Then

szzs(i, 0) = Trim(Left(dh, 11))

wz = 1

For j = 1 To 4

wz = InStr(wz, dh, vbTab) + 1

szzs(i, 1) = Trim(Mid(dh, wz, InStr(wz, dh, vbTab) - wz))

i = i + 1

End If

Loop

Close #1

i = 2594

Do While Not Cells(i, 3) = "--"

fn = "f:data est2" + Left(Cells(i, 1), 6) + ".txt"

Open fn For Input As #1

t1 = DateSerial(Left(Cells(i, 3), 4), Mid(Cells(i, 3), 5, 2), Right(Cells(i, 3), 2))

For k = 0 To 7800

t2 = szzs(k, 0)

If t1 &<= t2 Then

Cells(i, 15) = szzs(k, 1)

Exit For

End If

t1 = VBA.DateAdd("yyyy", 1, t1)

If t1 &< Date Then

Do While Not EOF(1)

Line Input #1, dh

If InStr(1, Left(dh, 10), "/") &> 0 Then

t2 = Left(dh, 10)

If t2 &> t1 Then

Cells(i, 12) = t2

wz = 1

For j = 1 To 4

wz = InStr(wz, dh, vbTab) + 1

Cells(i, 13) = Mid(dh, wz, InStr(wz, dh, vbTab) - wz)

Cells(i, 14) = "=(M" + Trim(Str(i)) + "-D" + Trim(Str(i)) + ")/D" + Trim(Str(i))

For k = 0 To 7800

t3 = szzs(k, 0)

If t3 = t2 Then

Cells(i, 16) = szzs(k, 1)

Exit For

End If

Exit Do

End If

Loop

End If

Close #1

i = i + 1

Loop

End Sub

Private Sub CommandButton13_Click()

"平安銀行(000001)業績報表明細 _ 數據中心 _ 東方財富網

Sheets("cw").Select

For i = 686 To 2818

au = "http://data.eastmoney.com/bbsj/stock" + Cells(i, 1) + "/yjbb.html"

fn = "f:datacw" + Cells(i, 1) + ".html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub CommandButton14_Click()

Dim t1 As Date, t2 As Date, d5(4) As Double

n = 9999: i = 3: zz = 0

t2 = VBA.DateAdd("yyyy", -3, Date)

Do While Cells(i, 5) &<&> ""

t1 = Cells(i, 1)

If t1 &> t2 Then

d5(zz) = Cells(i, 5)

m = 0

For j = 0 To 4

If m &< d5(j) Then m = d5(j)

If m &< n Then n = m

End If

i = i + 1

Loop

Cells(1, 6) = n

End Sub

Private Sub CommandButton15_Click()

window1.Hide

window3.Show

End Sub

Private Sub CommandButton2_Click()

au = "10年年度 - 財報查詢 - 和訊股票 - 和訊網"

fn = "f:data/test/2010- 1.html"

bz1 = URLDownloadToFile(0, au, fn, 0, 0)

Sheets("sheet1").Select

Cells(2, 1) = 1

Cells(2, 2) = bz1

For i = 2 To 78

au = "http://datainfo.hexun.com/wholemarket/html/cbcx.aspx?data_type=fld_released_datepage=" + Str(i) + "tag=2report=2010-12-31"

fn = "f:data/test/2010-" + Str(i) + ".html"

Cells(i + 1, 1) = i

Cells(i + 1, 2) = URLDownloadToFile(0, au, fn, 0, 0)

End Sub

Private Sub CommandButton16_Click()

wz1 = 87 "代碼位置

wz2 = 89 "行業數據位置

wz3 = 90 "產品數據位置

wz4 = 91 "產品類型位置

hywz = 84 "行業後位置

cpwz = 85 "產品後位置

cplxwz = 86 "產品類型後位置

i = 3

j = 3

Sheets("fx").Select

Do While Cells(i, 1) &<&> ""

Do While Cells(j, wz1) &<&> ""

If Cells(i, 1) = Left(Cells(j, wz1), 6) Then

Cells(i, hywz) = Cells(j, wz2)

Cells(i, cpwz) = Cells(j, wz3)

Cells(i, cplxwz) = Cells(j, wz4)

Exit Do

End If

j = j + 1

Loop

j = 3

i = i + 1

Loop

End Sub

Private Sub CommandButton18_Click()

Dim d5(10000, 52) As String, zz1(10000) As Integer

Sheets("tqs").Select

i = 2

Do While Cells(i, 1) &<&> ""

j = 1

Do While Cells(i, j) &<&> ""

d5(i, j) = Cells(i, j)

j = j + 1

Loop

zz1(i) = i

d5(i, 0) = j - 1

i = i + 1

Loop

i = 2: ta1 = 0: ta2 = 0: ta3 = 0: ta4 = 0: ta5 = 0: ta6 = 0

Do While d5(i, 0) &<&> ""

Select Case d5(i, 0)

Case "27"

ta1 = ta1 + 1

Case "32"

ta2 = ta2 + 1

Case "37"

ta3 = ta3 + 1

Case "42"

ta4 = ta4 + 1

Case "47"

ta5 = ta5 + 1

Case "52"

ta6 = ta6 + 1

End Select

j = i + 1

Do While zz1(j) &<&> 0

If Val(d5(zz1(i), 0)) &< Val(d5(zz1(j), 0)) Then

temp1 = zz1(i)

zz1(i) = zz1(j)

zz1(j) = temp1

End If

j = j + 1

Loop

i = i + 1

Loop

Sheets("tqscy").Select

Cells(12, 1) = ta1: Cells(12, 2) = ta2: Cells(12, 3) = ta3: Cells(12, 4) = ta4: Cells(12, 5) = ta5: Cells(12, 6) = ta6

i = 2

Do While d5(zz1(i + 1), 0) &<&> ""

k = 1

Cells(1, (i - 2) * 5 + 1) = d5(zz1(i), 1)

Cells(1, (i - 2) * 5 + 2) = d5(zz1(i), 2)

Cells(1, (i - 2) * 5 + 3) = d5(zz1(i), 0)

For j = 3 To d5(zz1(i), 0)

If j Mod 5 = 3 Then k = k + 1

Cells(k, (i - 2) * 5 + ((j + 2) Mod 5) + 1) = d5(zz1(i), j)

i = i + 1

Loop

End Sub

Private Sub CommandButton19_Click()

Dim d1(9) As Currency, nian1 As Integer

Sheets("hyfx").Select

i = 3

Do While Cells(i, 2) &<&> "" "將hyfx表單中的收入、凈利潤數據登記到d1數組中

For j = 0 To 4

d1(j * 2) = d1(j * 2) + Cells(i, 5 * j + 5)

d1(j * 2 + 1) = d1(j * 2 + 1) + Cells(i, 5 * j + 7)

i = i + 1

Loop

Sheets("print").Select

nian1 = Cells(2, 2)

Cells(34, 1) = "整體情況"

Cells(34, 2) = "年度"

Cells(34, 3) = "凈利潤和(千萬元)"

Cells(34, 4) = "收入和(億元)"

For i = 0 To 4

Cells(i + 35, 2) = nian1 + i "更改年度在這裡

Cells(i + 35, 3) = d1(i * 2) / 10000000 "凈利潤和

Cells(i + 35, 4) = d1(i * 2 + 1) / 100000000 "收入和

End Sub

Private Sub CommandButton20_Click()

Dim d1(3000, 30) As String, zz(3000), ta1(4) As Integer

Dim t1 As Date, t2 As Date, t3 As Date, t4 As Date, t5 As Date, t6 As Date

tt5 = 2011 "設置起始年度

t2 = Trim(Str(tt5 + 4)) + "/12/31"

t3 = Trim(Str(tt5 + 3)) + "/12/31"

t4 = Trim(Str(tt5 + 2)) + "/12/31"

t5 = Trim(Str(tt5 + 1)) + "/12/31"

t6 = Trim(Str(tt5)) + "/12/31"

ta1(0) = 10: ta1(1) = 4: ta1(2) = 6: ta1(3) = 3: ta1(4) = 8

z1 = 0 "設置篩選個數初始值

Sheets("fx").Select

i = 3

Do While Cells(i, 1) &<&> ""

d1(i, 0) = Cells(i, 1)

i = i + 1

Loop

sl = i - 1

Sheets("cw").Select

i = 3

Do While Cells(i, 1) &<&> ""

For j = 3 To sl

If Val(d1(j, 0)) = Val(Cells(i, 1)) Then

d1(j, 1) = Cells(i, 2)

For k = 1 To 21

t1 = Cells(i, k * 13 + 2)

Select Case t1

Case t6

For q = 2 To 6

d1(j, q) = Cells(i, k * 13 - ta1(q - 2))

Case t5

For q = 7 To 11

d1(j, q) = Cells(i, k * 13 - ta1(q - 7))

Case t4

For q = 12 To 16

d1(j, q) = Cells(i, k * 13 - ta1(q - 12))

Case t3

For q = 17 To 21

d1(j, q) = Cells(i, k * 13 - ta1(q - 17))

Case t2

For q = 22 To 26

d1(j, q) = Cells(i, k * 13 - ta1(q - 22))

End Select

End If

i = i + 1

Loop

For j = 3 To i - 1

If Val(d1(j, 5)) &> 0 And Val(d1(j, 25)) &> 0 Then If ((Val(d1(j, 25)) / Val(d1(j, 5))) ^ (1 / 4) - 1) &< 0.05 Then d1(j, 0) = 0

For k = 0 To 4

"If k &< 4 And Val(d1(j, k * 5 + 5)) &>= Val(d1(j, (k + 1) * 5 + 5)) Then d1(j, 0) = 0

If Val(d1(j, k * 5 + 5)) &<= 0 Then d1(j, 0) = 0

If Val(d1(j, 0)) &> 0 Then zz(z1) = j: z1 = z1 + 1

Sheets("hyfx").Select

For i = 3 To z1 - 1

For j = 0 To 29

Cells(i, j + 1) = d1(zz(i - 3), j)

End Sub

Private Sub CommandButton3_Click()

Dim dm(4000) As String, t1 As Date, t2 As Date, dh As String, d1(60, 4) As String, d2(9, 4) As String, d3(4000, 4000, 4) As String, d4(2000000, 10, 4) As String

Dim fh(4) As Integer

tpl = 0.007 "設定允許的偏離值（比率）

pl1 = 1 - tpl: pl2 = 1 + tpl

yue = -1 "設定採集時間開始端為上個月

Sheets("fx").Select

i = 3

Do While Cells(i, 1) &<&> "" "採集資料庫中的股票代碼

dm(i) = Cells(i, 1)

i = i + 1

Loop

sl = i - 1 "統計資料庫中的股票數量

"sl = 100

Sheets("tqs").Select

fn = "f:data est3" + TextBox1.Text + ".txt"

Cells(2, 1) = TextBox1.Text

a: t1 = VBA.DateAdd("m", yue, Date) "將時間起點往後推"yue"個月

i = 0

Open fn For Input As #1

Do While Not EOF(1) "讀取目標證券最近10個交易日的交易數據

Line Input #1, dh

If InStr(1, dh, "/") &> 0 Then

t2 = Left(dh, 10)

If t2 &> t1 Then

wz = 1

For j = 0 To 4

d1(i, j) = Mid(dh, wz, InStr(wz, dh, vbTab) - wz)

wz = InStr(wz, dh, vbTab) + 1

i = i + 1

End If

Loop

Close #1

sl1 = i - 1 "取得採集期間內開盤日數量

If sl1 &< 10 Then yue = yue - 1: GoTo a "如果採集的開盤日小於10日則將數據採集時間提前一個月

sp = d1(sl1 - 10, 4) "取得10個交易日前一日的收盤價

Cells(2, 2) = sp

For i = 0 To 9

For j = 0 To 4

d2(i, j) = d1(sl1 - 9 + i, j)

If j &<&> 0 Then d2(i, j) = d2(i, j) / sp

Cells(2, i * 5 + j + 3) = d2(i, j)

"--------------分割線---------------

nian = -10 "設定查找時間為過去10年

t1 = VBA.DateAdd("yyyy", nian, Date)

For i = 3 To sl "取出最近10年全部股票的日線數據

fn = "f:data est3" + dm(i) + ".txt"

j = 1: d3(i, 0, 0) = dm(i) "將股票代碼存放在三維數組的頭部

Open fn For Input As #1

Do While Not EOF(1)

Line Input #1, dh

If InStr(1, dh, "/") &> 0 Then

t2 = Left(dh, 10)

If t2 &> t1 Then

wz = 1

For k = 0 To 4

d3(i, j, k) = Mid(dh, wz, InStr(wz, dh, vbTab) - wz)

wz = InStr(wz, dh, vbTab) + 1

j = j + 1

End If

Loop

Close #1

If i Mod 100 = 0 Then Cells(1, 2) = i

"--------------分割線---------------

o = 0

For i = 3 To sl

For j = 1 To 4000

If d3(i, j + 10, 0) = "" Then Exit For

d4(o, 0, 0) = d3(i, 0, 0) "將股票代碼存放在d4數組的頭部

d4(o, 0, 1) = d3(i, j, 4) "將參照日收盤價存放在d4數組的頸部

bz = 0

For k = 0 To 9

fh(1) = 0: fh(2) = 1: fh(3) = 1: fh(4) = 0 "設置4個標誌值為0，表示同時判斷開盤價、最高價、最低價、收盤價，不判斷的設置成1

For q = 1 To 4

If d4(o, 0, 1) &> 0 Then

If (Val(d3(i, j + k + 1, q)) / Val(d4(o, 0, 1))) &> Val(d2(k, q)) * pl1 And (Val(d3(i, j + k + 1, q)) / Val(d4(o, 0, 1))) &< Val(d2(k, q)) * pl2 Then fh(q) = 1

"如果價格處於偏差範圍內，則設置標誌位為「符合」

End If

If fh(1) = 1 And fh(2) = 1 And fh(3) = 1 And fh(4) = 1 Then "將符合條件的日線存入結果數組

For q = 0 To 4

d4(o, k + 1, q) = d3(i, j + k + 1, q)

"Cells(o + 3, k * 5 + 3 + q) = d4(o, k + 1, q)

bz = 1

Else

Exit For

End If

If bz = 1 And k &> 5 Then o = o + 1: If o Mod 100 = 0 Then Cells(1, 3) = o: Cells(1, 4) = i

For i = 3 To o + 3 "列印結果

Cells(i, 1) = d4(i - 3, 0, 0)

Cells(i, 2) = d4(i - 3, 0, 1)

For j = 0 To 9

For k = 0 To 4

Cells(i, j * 5 + k + 3) = d4(i - 3, j + 1, k)

End Sub

Private Sub CommandButton4_Click()

Dim d1(4000, 13) As String, ts1 As String, dwz(13) As Integer

Dim tkjq As Date, kjq As Date, ntos1 As New ntos

Sheets("t2").Select

ts1 = Cells(1, 3)

kjq = DateSerial(Val(Mid(ts1, InStr(1, ts1, ".") - 4, 4)), Val(Mid(ts1, InStr(1, ts1, ".") + 1, 2)), Val(Right(ts1, 2)))

"每股收益每股收益（扣除）營業收入同比增長（%）凈利潤同比增長(%) 每股凈資產凈資產收益率每股經營現金流量銷售毛利率（%）利潤分配股息率會計期

"基本每股收益(元)2016.09.30 營業收入(元)2016.09.30 凈利潤(元)2016.09.30 每股凈資產(元)2016.09.30 加權凈資產收益率(%)2016.09.30 每股經營現金流(元)2016.09.30 銷售毛利率(%)2016.09.30 基本每股收益(同比增長率)(%)2016.09.30 營業收入(同比增長率)(%)2016.09.30 所屬同花順行業

"1基本每股收益(元) 3營業收入(元) 5凈利潤 (元) 7每股凈資產 (元) 8加權凈資產收益率 (%) 9每股經營活動產生的現金流量凈額(元) 10銷售毛利率(%) 每股資本公積(元)

"每股未分配利潤(元) 4營業收入(同比增長率)(%) 6凈利潤同比增長率 (%) 預告凈利潤(元) 預測每股凈資產 (元) 預測凈資產收益率 (%)

"凈利潤(元) 股東權益合計(元) 現價(元) 漲跌幅(%) 凈資產(同比增長率)(%)

"同花順查詢關鍵字：2015年每股收益，營業收入，凈利潤，每股凈資產，凈資產收益率，每股經營現金流量，銷售毛利率

For k = 1 To 17 "這個循環用於獲取格式化數據所在的列

ts1 = Cells(1, k)

If InStr(1, ts1, "基本每股收益(元)") &> 0 Then

dwz(1) = k

Else

If InStr(1, ts1, "營業收入(元)") &> 0 Then

dwz(3) = k

Else

If InStr(1, ts1, "營業收入(同比增長率)(%)") &> 0 Then

dwz(4) = k

Else

If InStr(1, ts1, "凈利潤(元)") &> 0 Then

dwz(5) = k

Else

If InStr(1, ts1, "凈利潤同比增長率(%)") &> 0 Then

dwz(6) = k

Else

If InStr(1, ts1, "每股凈資產(元)") &> 0 Then

dwz(7) = k

Else

If InStr(1, ts1, "加權凈資產收益率(%)") &> 0 Then

dwz(8) = k

Else

If InStr(1, ts1, "每股經營現金流(元)") &> 0 Then

dwz(9) = k

Else

If InStr(1, ts1, "銷售毛利率(%)") &> 0 Then dwz(10) = k

End If

i = 3: dwz(2) = 30: dwz(11) = 30: dwz(12) = 30

Do While Cells(i, 1) &<&> ""

d1(i, 0) = Left(Cells(i, 1), 6)

For j = 1 To 10

d1(i, j) = Cells(i, dwz(j))

d1(i, 13) = kjq

i = i + 1

Loop

i = 3

Sheets("cw").Select

Do While Cells(i, 1) &<&> ""

tkjq = Cells(i, 15)

If Cells(i, 15) &<&> "" And tkjq &<&> kjq Then

Range(Cells(i, 3), Cells(i, 15)).Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

j = 3

Do While d1(j, 0) &<&> ""

If Val(Cells(i, 1)) = Val(d1(j, 0)) And Cells(i, 3) = "" Then "下載財務數據

For k = 1 To 12

Cells(i, k + 2) = d1(j, k)

Cells(i, 15) = kjq

End If

j = j + 1

Loop

End If

i = i + 1

Loop

End Sub

Private Sub CommandButton5_Click()

Dim dm(4000) As String, t1 As Date, t2 As Date, dh As String, d1(60, 4) As String, d2(9, 4) As String, d3(4000, 3000, 9) As String

Dim jj(19, 1) As Currency, zz2 As Integer

Sheets("fx").Select

i = 3

Do While Cells(i, 1) &<&> "" "採集資料庫中的股票代碼

dm(i) = Cells(i, 1)

i = i + 1

Loop

sl = i - 1 "統計資料庫中的股票數量

sl = 13

"--------------分割線---------------

nian = -4 "設定查找時間範圍為過去"nian"年

t1 = VBA.DateAdd("yyyy", nian, Date)

For i = 3 To sl "取出最近"nian"年全部股票的日線數據

fn = "f:data est3" + dm(i) + ".txt"

j = 1: d3(i, 0, 0) = dm(i) "將股票代碼存放在三維數組的頭部

Open fn For Input As #1

Do While Not EOF(1)

Line Input #1, dh

If InStr(1, dh, "/") &> 0 Then

t2 = Left(dh, 10)

If t2 &> t1 Then

wz = 1

For k = 0 To 5

d3(i, j, k) = Mid(dh, wz, InStr(wz, dh, vbTab) - wz)

wz = InStr(wz, dh, vbTab) + 1

d3(i, j, 6) = Mid(dh, wz, wz)

zz2 = (zz2 + 1) Mod 20

jj(zz2, 0) = Val(d3(i, j, 5))

jj(zz2, 1) = Val(d3(i, j, 6))

If j &> 20 Then

jyl = 0: jye = 0

For q = 0 To 19

jyl = jyl + jj((20 + zz2 - q) Mod 20, 0)

jye = jye + jj((20 + zz2 - q) Mod 20, 1)

If q = 2 Then d3(i, j, 7) = jye / jyl

If q = 9 Then d3(i, j, 8) = jye / jyl

d3(i, j, 9) = jye / jyl

End If

j = j + 1

End If

Loop

d3(i, 0, 1) = j - 1 "將該股票的交易日總數存入數組頸部

Close #1

If i Mod 100 = 0 Then Cells(1, 2) = i

Sheets("sycs").Select "列印結果

For i = 3 To sl

For j = 0 To Val(d3(i, 0, 1))

For k = 0 To 9

Cells(i, j * 10 + k + 1) = d3(i, j, k)

End Sub

Private Sub CommandButton6_Click()

"利潤_聯創電子(002036)_個股資料_行情中心_和訊網

Sheets("fx").Select

For i = 3 To 2818

au = "利潤_平安銀行(000001)_個股資料_行情中心_和訊網" + Cells(i, 1) + "accountdate=" + Trim(Str(Val(Left(Cells(i, 86), 4)) - 1)) + ".12.31"

fn = "f:dataipozclr" + Cells(i, 1) + "-" + Trim(Str(Val(Left(Cells(i, 86), 4)) - 1)) + "利潤.html"

tt1 = URLDownloadToFile(0, au, fn, 0, 0)

au = "資產負債_平安銀行(000001)_個股資料_行情中心_和訊網" + Cells(i, 1) + "accountdate=" + Left(Cells(i, 86), 4) + ".12.31"

fn = "f:dataipozclr" + Cells(i, 1) + "-" + Left(Cells(i, 86), 4) + "資產.html"

tt1 = URLDownloadToFile(0, au, fn, 0, 0)

Cells(i, 114) = Val(Left(Cells(i, 86), 4)) - 1

Cells(i, 115) = Val(Left(Cells(i, 86), 4))

End Sub

Private Sub CommandButton7_Click()

Dim b1(3) As Long, s1 As String

Sheets("fx").Select

For i = 3 To 2818

fn = "f:dataipozclr" + Cells(i, 1) + "-" + Trim(Str(Val(Left(Cells(i, 86), 4)) - 1)) + "利潤.html"

Open fn For Input As #1

bu = ""

Do While Not EOF(1)

Line Input #1, dh

bu = bu + dh

Loop

Close #1

b(0) = InStr(1, bu, "營業收入")

b(1) = InStr(1, bu, "營業成本")

b(2) = InStr(1, bu, "凈利潤&<")

For j = 0 To 2

If b(j) &> 0 Then b(j) = InStr(b(j), bu, "&") + 4

If b(j) &> 0 Then

b1(j) = InStr(b(j), bu, "&")

s1 = Mid(bu, b(j), b1(j) - b(j))

s1 = Mid(s1, InStr(1, s1, ">") + 1, b1(j) - b(j))

If InStr(1, s1, "&<") &> 0 Then s1 = Mid(s1, 1, InStr(1, s1, "&<") - 1)

Cells(i, 118 + j) = s1

End If

fn = "f:dataipozclr" + Cells(i, 1) + "-" + Left(Cells(i, 86), 4) + "資產.html"

Open fn For Input As #1

bu = ""

Do While Not EOF(1)

Line Input #1, dh

bu = bu + dh

Loop

Close #1

b(0) = InStr(1, bu, "資產總計")

b(1) = InStr(1, bu, "實收資本")

b(2) = InStr(1, bu, "所有者權益")

For j = 0 To 2

If b(j) &> 0 Then b(j) = InStr(b(j), bu, "&") + 4

If b(j) &> 0 Then

b1(j) = InStr(b(j), bu, "&")

s1 = Mid(bu, b(j), b1(j) - b(j))

s1 = Mid(s1, InStr(1, s1, ">") + 1, b1(j) - b(j))

If InStr(1, s1, "&<") &> 0 Then s1 = Mid(s1, 1, InStr(1, s1, "&<") - 1)

Cells(i, 121 + j) = s1

End If

Cells(i, 117) = "=dp" + Trim(Str(i)) + "/dr" + Trim(Str(i))

If InStr(1, Range("dm" + Trim(Str(i))).Text, "#") &> 0 Then Cells(i, 117) = "--"

Cells(i, 116) = "=DG" + Trim(Str(i)) + "/DM" + Trim(Str(i))

If InStr(1, Range("dl" + Trim(Str(i))).Text, "#") &> 0 Then Cells(i, 116) = "--"

Cells(i, 124) = "=(DN" + Trim(Str(i)) + "-DO" + Trim(Str(i)) + ")/DN" + Trim(Str(i))

If InStr(1, Range("dt" + Trim(Str(i))).Text, "#") &> 0 Then Cells(i, 124) = "--"

Cells(i, 125) = "=DP" + Trim(Str(i)) + "/DN" + Trim(Str(i))

If InStr(1, Range("du" + Trim(Str(i))).Text, "#") &> 0 Then Cells(i, 125) = "--"

End Sub

Private Sub CommandButton8_Click()

Dim t1 As Date, t2 As Date, wz As Integer

Sheets("fx").Select

For i = 3 To 2818

If Left(Cells(i, 1), 1) = "6" Then fn = "f:data est1SH#" + Cells(i, 1) + ".txt" Else fn = "f:data est1SZ#" + Cells(i, 1) + ".txt"

Open fn For Input As #1

t1 = DateSerial(Left(Cells(i, 86), 4), Mid(Cells(i, 86), 5, 2), Right(Cells(i, 86), 2))

t1 = VBA.DateAdd("yyyy", 1, t1)

If t1 &< Date Then

Do While Not EOF(1)

Line Input #1, dh

If InStr(1, Left(dh, 10), "/") &> 0 Then

t2 = Left(dh, 10)

If t2 &> t1 Then

Cells(i, 126) = t2

wz = 1

For j = 1 To 4

wz = InStr(wz, dh, vbTab) + 1

Cells(i, 127) = Mid(dh, wz, InStr(wz, dh, vbTab) - wz)

Cells(i, 128) = "=(DW" + Trim(Str(i)) + "-DG" + Trim(Str(i)) + ")/DG" + Trim(Str(i))

Exit Do

End If

Loop

End If

Close #1

End Sub

window2（代碼）：

Dim tt5 As Integer, t1 As Date, t2 As Date, t3 As Date, t4 As Date, t5 As Date, t6 As Date, ta1(5) As Integer

Private Sub CommandButton1_Click()

window2.Hide

window1.Show

End Sub

Private Sub CommandButton2_Click()

Dim tj(2, 4) As String, d1(3000, 30) As String, tjb(2) As Integer

tj1 = 17 "第一個篩選欄

tj2 = 85 "第二個篩選欄

tj3 = 84 "第三個篩選欄

tj(0, 0) = TextBox1.Text

tj(0, 1) = TextBox2.Text

tj(0, 2) = TextBox3.Text

tj(0, 3) = TextBox4.Text

tj(0, 4) = TextBox5.Text

tj(1, 0) = TextBox6.Text

tj(1, 1) = TextBox7.Text

tj(1, 2) = TextBox8.Text

tj(1, 3) = TextBox9.Text

tj(1, 4) = TextBox10.Text

tj(2, 0) = TextBox11.Text

tj(2, 1) = TextBox12.Text

tj(2, 2) = TextBox13.Text

tj(2, 3) = TextBox14.Text

tj(2, 4) = TextBox15.Text

ta1(0) = 10

ta1(1) = 4

ta1(2) = 6

ta1(3) = 3

ta1(4) = 8

k = 0

Sheets("fx").Select

i = 3

Do While Cells(i, 1) &<&> ""

For j = 0 To 4

If Not (tj(0, j) = "") And InStr(1, Cells(i, tj1), tj(0, j)) &> 0 Then tjb(0) = 1

If Not (tj(1, j) = "") And InStr(1, Cells(i, tj2), tj(1, j)) &> 0 Then tjb(1) = 1

If Not (tj(2, j) = "") And InStr(1, Cells(i, tj3), tj(2, j)) &> 0 Then tjb(2) = 1

For j = 0 To 2

If tj(j, 0) = "" And tj(j, 1) = "" And tj(j, 2) = "" And tj(j, 3) = "" And tj(j, 4) = "" Then tjb(j) = 1

If tjb(0) = 1 And tjb(1) = 1 And tjb(2) = 1 Then

For q = 0 To 1

d1(k, q) = Cells(i, q + 1)

d1(k, 27) = Cells(i, tj1)

d1(k, 28) = Cells(i, tj2)

d1(k, 29) = Cells(i, tj3)

k = k + 1

End If

tjb(0) = 0

tjb(1) = 0

tjb(2) = 0

i = i + 1

Loop

sl = k - 1

Sheets("cw").Select

Dim ttt1 As Integer, ttt2 As Integer

tt5 = Left(Cells(3, 15), 4) "獲取年度

ttt2 = 1

For i = 4 To 33

ttt1 = Left(Cells(i, 15), 4)

If ttt1 &> tt5 Then tt5 = ttt1

If InStr(1, Cells(i, 15), "/12/31") &> 0 Then ttt2 = 0

tt5 = tt5 - ttt2

Sheets("print").Select "將開始年度保存在print表單中

Cells(2, 2) = tt5 - 4

Sheets("cw").Select

t6 = Trim(Str(tt5 - 4)) + "/12/31"

t5 = Trim(Str(tt5 - 3)) + "/12/31"

t4 = Trim(Str(tt5 - 2)) + "/12/31"

t3 = Trim(Str(tt5 - 1)) + "/12/31"

t2 = Trim(Str(tt5)) + "/12/31"

i = 3

Do While Cells(i, 1) &<&> ""

For j = 0 To sl

If d1(j, 0) = Cells(i, 1) Then

For k = 1 To 21

t1 = Cells(i, k * 13 + 2)

Select Case t1

Case t6

For q = 2 To 6

d1(j, q) = Cells(i, k * 13 - ta1(q - 2))

Case t5

For q = 7 To 11

d1(j, q) = Cells(i, k * 13 - ta1(q - 7))

Case t4

For q = 12 To 16

d1(j, q) = Cells(i, k * 13 - ta1(q - 12))

Case t3

For q = 17 To 21

d1(j, q) = Cells(i, k * 13 - ta1(q - 17))

Case t2

For q = 22 To 26

d1(j, q) = Cells(i, k * 13 - ta1(q - 22))

End Select

End If

i = i + 1

Loop

Sheets("hyfx").Select

i = 3

Do While d1(i - 3, 0) &<&> ""

For j = 0 To 29

Cells(i, j + 1) = d1(i - 3, j)

i = i + 1

Loop

For j = i To i + 20

For k = 0 To 29

Cells(j, k + 1) = ""

End Sub

Private Sub CommandButton3_Click()

Dim d1(30) As String

tt5 = 2011 "設置起始年度

t2 = Trim(Str(tt5 + 4)) + "/12/31"

t3 = Trim(Str(tt5 + 3)) + "/12/31"

t4 = Trim(Str(tt5 + 2)) + "/12/31"

t5 = Trim(Str(tt5 + 1)) + "/12/31"

t6 = Trim(Str(tt5)) + "/12/31"

ta1(0) = 10: ta1(1) = 4: ta1(2) = 6: ta1(3) = 3: ta1(4) = 8

Sheets("cw").Select

i = 3

Do While Cells(i, 1) &<&> ""

If Val(TextBox16.Text) = Val(Cells(i, 1)) Or TextBox16.Text = Cells(i, 2) Then

d1(0) = Cells(i, 1): d1(1) = Cells(i, 2)

For k = 1 To 21

t1 = Cells(i, k * 13 + 2)

Select Case t1

Case t6

For q = 2 To 6

d1(q) = Cells(i, k * 13 - ta1(q - 2))

Case t5

For q = 7 To 11

d1(q) = Cells(i, k * 13 - ta1(q - 7))

Case t4

For q = 12 To 16

d1(q) = Cells(i, k * 13 - ta1(q - 12))

Case t3

For q = 17 To 21

d1(q) = Cells(i, k * 13 - ta1(q - 17))

Case t2

For q = 22 To 26

d1(q) = Cells(i, k * 13 - ta1(q - 22))

End Select

End If

i = i + 1

Loop

Sheets("hyfx").Select

i = 3

Do While Cells(i, 1) &<&> ""

i = i + 1

Loop

For j = 0 To 29

Cells(i, j + 1) = d1(j)

Cells(i + 1, j + 1) = ""

End Sub

Private Sub CommandButton4_Click()

Dim d1(200, 30) As String

tt5 = 2011 "設置起始年度

t2 = Trim(Str(tt5 + 4)) + "/12/31"

t3 = Trim(Str(tt5 + 3)) + "/12/31"

t4 = Trim(Str(tt5 + 2)) + "/12/31"

t5 = Trim(Str(tt5 + 1)) + "/12/31"

t6 = Trim(Str(tt5)) + "/12/31"

ta1(0) = 10: ta1(1) = 4: ta1(2) = 6: ta1(3) = 3: ta1(4) = 8

Sheets("hyfx").Select

i = 3

Do While Cells(i, 1) &<&> ""

d1(i, 0) = Cells(i, 1)

i = i + 1

Loop

sl = i - 1

Sheets("cw").Select

i = 3

Do While Cells(i, 1) &<&> ""

For j = 0 To sl

If Val(d1(j, 0)) = Val(Cells(i, 1)) Then

d1(j, 1) = Cells(i, 2)

For k = 1 To 21

t1 = Cells(i, k * 13 + 2)

Select Case t1

Case t6

For q = 2 To 6

d1(j, q) = Cells(i, k * 13 - ta1(q - 2))

Case t5

For q = 7 To 11

d1(j, q) = Cells(i, k * 13 - ta1(q - 7))

Case t4

For q = 12 To 16

d1(j, q) = Cells(i, k * 13 - ta1(q - 12))

Case t3

For q = 17 To 21

d1(j, q) = Cells(i, k * 13 - ta1(q - 17))

Case t2

For q = 22 To 26

d1(j, q) = Cells(i, k * 13 - ta1(q - 22))

End Select

End If

i = i + 1

Loop

Sheets("hyfx").Select

i = 3

Do While d1(i, 0) &<&> ""

For j = 0 To 29

Cells(i, j + 1) = d1(i, j)

i = i + 1

Loop

End Sub

window3（代碼）：

Dim d1(300, 36) As String, t1 As Date, t2 As Date, t3 As Date, t4 As Date, t5 As Date, t6 As Date

Private Sub CommandButton1_Click()

t2 = "2015/12/31"

t3 = "2014/12/31"

t4 = "2013/12/31"

t5 = "2012/12/31"

t6 = "2011/12/31"

Sheets("s2").Select

sl = 37

For i = 0 To sl

d1(i, 0) = Cells(i + 2, 1)

Sheets("cw").Select

For i = 3 To 2818

For j = 0 To sl

If d1(j, 0) = Cells(i, 1) Then

For k = 1 To 21

t1 = Cells(i, k * 13 + 2)

Select Case t1

Case t2

d1(j, 1) = Cells(i, k * 13 - 10)

d1(j, 2) = Cells(i, k * 13 - 8)

d1(j, 3) = Cells(i, k * 13 - 7)

d1(j, 4) = Cells(i, k * 13 - 6)

d1(j, 5) = Cells(i, k * 13 - 5)

d1(j, 6) = Cells(i, k * 13 - 3)

d1(j, 7) = Cells(i, k * 13 + 2)

Case t3

d1(j, 8) = Cells(i, k * 13 - 10)

d1(j, 9) = Cells(i, k * 13 - 8)

d1(j, 10) = Cells(i, k * 13 - 7)

d1(j, 11) = Cells(i, k * 13 - 6)

d1(j, 12) = Cells(i, k * 13 - 5)

d1(j, 13) = Cells(i, k * 13 - 3)

d1(j, 14) = Cells(i, k * 13 + 2)

Case t4

d1(j, 15) = Cells(i, k * 13 - 10)

d1(j, 16) = Cells(i, k * 13 - 8)

d1(j, 17) = Cells(i, k * 13 - 7)

d1(j, 18) = Cells(i, k * 13 - 6)

d1(j, 19) = Cells(i, k * 13 - 5)

d1(j, 20) = Cells(i, k * 13 - 3)

d1(j, 21) = Cells(i, k * 13 + 2)

Case t5

d1(j, 22) = Cells(i, k * 13 - 10)

d1(j, 23) = Cells(i, k * 13 - 8)

d1(j, 24) = Cells(i, k * 13 - 7)

d1(j, 25) = Cells(i, k * 13 - 6)

d1(j, 26) = Cells(i, k * 13 - 5)

d1(j, 27) = Cells(i, k * 13 - 3)

d1(j, 28) = Cells(i, k * 13 + 2)

Case t6

d1(j, 29) = Cells(i, k * 13 - 10)

d1(j, 30) = Cells(i, k * 13 - 8)

d1(j, 31) = Cells(i, k * 13 - 7)

d1(j, 32) = Cells(i, k * 13 - 6)

d1(j, 33) = Cells(i, k * 13 - 5)

d1(j, 34) = Cells(i, k * 13 - 3)

d1(j, 35) = Cells(i, k * 13 + 2)

End Select

End If

Sheets("s2").Select

For i = 0 To sl

For j = 0 To 36

Cells(i + 2, j + 16) = d1(i, j)

End Sub

類 ntos（代碼）：

Private sw As Integer, gw As Integer

Public Function ns(ByVal a As Integer) As String

Dim s1 As String

gw = ((a - 1) Mod 26) + 65

sw = (a - 1) 26

s1 = Chr(gw)

If sw &>= 1 Then s1 = ns(sw) + s1

ns = s1

End Function

去巨潮資訊查詢