第八章他山之石 附件3示例代碼
Sub char_cal()
Sheets("分類數據").Select
Cells.Select
Selection.Copy
Sheets("temp").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues，Operation:=xlNone，SkipBlanks _
:=False，Transpose:=False
hn=Sheets("temp").Range("A1048576").End(xlUp).Row
sn=Sheets("temp").Range("XFD1").End(xlToLeft).Column
'數據清除斷行
Fori=1 To hn
If Sheets("temp").Range(Cells(i，10000)，Cells(i，10000)).End(xlToLeft).Column Rows(i).Delete
End If
Next i
'清除當前不能交易的個股
hn=Sheets("temp").Range("A1048576").End(xlUp).Row
sn=Sheets("temp").Range("XFD1").End(xlToLeft).Column
n4z=1
Fori=sn To 2 Step-1
count4z=0
Forj=hn To hn-n4z+1 Step-1
If Sheets("temp").Cells(j，i)=0 Then
count4z=count4z+1
Else
End If
Next j
If count4z >=n4z Then
Columns(i).Delete
End If
Next i
'清除連續5天以上的0值
hn=Sheets("temp").Range("A1048576").End(xlUp).Row
sn=Sheets("temp").Range("XFD1").End(xlToLeft).Column
Fori=2 To sn
temp4v=1
Forj=5 To hn
If Sheets("temp").Cells(j，i)=0 Then
If Sheets("temp").Cells(j-1，i)=0 Then
temp4v=temp4v+1
Else
End If
Else
If Sheets("temp").Cells(j-1，i)=0 And temp4v > 4 Then
Fork=j To j-temp4v Step-1
Sheets("temp").Cells(k，i)=Null
Next k
temp4v=1
Else
temp4v=1
End If
End If
Next j
Next i
hn=Sheets("temp").Range("A1048576").End(xlUp).Row
sn=Sheets("temp").Range("XFD1").End(xlToLeft).Column
'開始計算beta
Fori=2 To sn
hnn=Sheets("temp").Cells(hn，i).End(xlUp).Row
Sheets("等級集群").Cells(1，i-1)=Sheets("temp").Cells(1，i)
If hnn <=4 Then
hnn=4
Sheets("等級集群").Cells(3，i-1)=WorksheetFunction.Slope(Range(Sheets("temp").Cells(hnn，i)，Sheets("temp").Cells(hn，i))，Range(Sheets("temp").Cells(hnn，2)，Sheets("temp").Cells(hn，2)))
Sheets("等級集群").Cells(2，i-1)=WorksheetFunction.Average(Range(Sheets("temp").Cells(hnn，i)，Sheets("temp").Cells(hn，i)))-Sheets("等級集群").Cells(3，i-1)*WorksheetFunction.Average(Range(Sheets("temp").Cells(hnn，2)，Sheets("temp").Cells(hn，2)))
ElseIf hn-hnn <20 Then
Sheets("等級集群").Cells(3，i-1)=Null
Sheets("等級集群").Cells(2，i-1)=Null
Else
Sheets("等級集群").Cells(3，i-1)=WorksheetFunction.Slope(Range(Sheets("temp").Cells(hnn，i)，Sheets("temp").Cells(hn，i))，Range(Sheets("temp").Cells(hnn，2)，Sheets("temp").Cells(hn，2)))
Sheets("等級集群").Cells(2，i-1)=WorksheetFunction.Average(Range(Sheets("temp").Cells(hnn，i)，Sheets("temp").Cells(hn，i)))-Sheets("等級集群").Cells(3，i-1)*WorksheetFunction.Average(Range(Sheets("temp").Cells(hnn，2)，Sheets("temp").Cells(hn，2)))
End If
Next i
hn=Sheets("等級集群").Range("A1048576").End(xlUp).Row
sn=Sheets("等級集群").Range("XFD1").End(xlToLeft).Column
Fori=sn To 1 Step-1
If Sheets("等級集群").Cells(2，i)="" Then
Sheets("等級集群").Columns(i).Delete
Else
End If
Next i
Sheets("等級集群").Select
End Sub
Option Base 1
Type stock
id As String
gp As Integer
ch() As Variant
End Type
Type charac
ch() As Variant
End Type
Sub data_read()
hn=Sheets("等級集群").Range("A1048576").End(xlUp).Row
sn=Sheets("等級集群").Range("XFD1").End(xlToLeft).Column
Dim stockdata() As stock'stock 向量數組
ReDim stockdata(sn)
Fori=1 To sn
ReDim stockdata(i).ch(hn-1)
stockdata(i).id=Sheets("等級集群").Cells(1，i)
stockdata(i).gp=i
Forj=1 To hn-1
stockdata(i).ch(j)=Sheets("等級集群").Cells(j+1，i)
Next j
Next i
'給出分組後的向量，向量內元素為stock.id
num4gp=Int(CDbl(InputBox("分類數量"，"等級集群法數量輸入")))
gp_matrix=dist_2g(stockdata，num4gp)
Fori=LBound(gp_matrix) To UBound(gp_matrix)
Forj=LBound(gp_matrix，2) To UBound(gp_matrix，2)
If gp_matrix(i，j) <> "" Then
stockdata(gp_matrix(i，j)).gp=i
Else
End If
Next j
Next i
'aa=centr(stockdata，num4gp)
flvec=tars_vec(stockdata，num4gp)
'向“數據”頁寫入數據
Sheets("數據").Select
Cells.Select
Selection.Delete
sn4sj=Sheets("temp").Range("XFD1").End(xlToLeft).Column
hn4sj=Sheets("temp").Range("A1048576").End(xlUp).Row
Fori=1 To hn4sj
Sheets("數據").Cells(i，1)=Sheets("temp").Cells(i，1)
Sheets("數據").Cells(i，UBound(flvec)+2)=Sheets("temp").Cells(i，2)
Next i
Fori=LBound(flvec) To UBound(flvec)
Forj=1 To sn4sj
If flvec(i)=Sheets("temp").Cells(1，j) Then
Fork=1 To hn4sj
Sheets("數據").Cells(k，i+1)=Sheets("temp").Cells(k，j)
Next k
Exit For
Else
End If
Next j
Next i
Sheets("處理").Select
End Sub
Function tars_vec(stockdata() As stock，num4gp As Variant) As Variant
Dim output()
ReDim output(num4gp)
Dim temp_id()
Dim temp_dis()
Fori=1 To num4gp
iter=0
Forj=1 To UBound(stockdata)
If stockdata(j).gp=i Then
iter=iter+1
ReDim Preserve temp_id(iter)
ReDim Preserve temp_dis(iter)
temp_id(iter)=stockdata(j).id
temp_dis(iter)=dist(stockdata(j).ch，centr(stockdata，i))
Else
End If
Next j
'寫入輸出向量
temp4id=smin_id(temp_dis)
output(i)=temp_id(temp4id)
Next i
tars_vec=output
End Function
Function centr(stockdata() As stock，po As Variant) As Variant
Dim temp()
ReDim temp(UBound(stockdata(1).ch))
temp_val=0
Fori=1 To UBound(stockdata) '類別
If stockdata(i).gp=po Then
Fork=1 To UBound(stockdata(1).ch)
temp(k)=temp(k)+stockdata(i).ch(k)
Next k
temp_val=temp_val+1
Else
End If
Next i
Fork=1 To UBound(stockdata(1).ch)
temp(k)=temp(k)/temp_val
Next k
centr=temp
End Function
Function dist_2g(stock_vec() As stock，target_num As Variant) As Variant
sn=UBound(stock_vec)
Dim dis_m() As Variant
ReDim dis_m(1 To sn,1 To sn)
'產生距離矩陣dis_m，等待查找
Fori=1 To sn
Forj=1 To sn
dis_m(i，j)=dist(stock_vec(i).ch，stock_vec(j).ch)
Next j
Next i
'基於dmin等級集群，其中建立新分類代碼向量gp_vec(),該向量元素為自然數序列，
'初始gp_vec()賦值
Dim gp_matrix()
ReDim gp_matrix(sn，sn)
Fori=1 To sn
gp_matrix(i，1)=stock_vec(i).gp
Next i
Dim gp_matrix_final()
ReDim gp_matrix_final(sn，sn)
gp_matrix_final=gp_matrix
Dim dis_gp_matrix()
Dim temp4rank()
Do '判斷是否完成分類
'分類
ReDim dis_gp_matrix(UBound(gp_matrix_final)，UBound(gp_matrix_final))
Fori=1 To UBound(gp_matrix_final)'第一個類別迭代器
Forj=1 To UBound(gp_matrix_final)'第二個類別迭代器
iterator=1
If i=j Then
Else
ii=1
Do While gp_matrix_final(i，ii) <> "" And ii <=sn
jj=1
Do While gp_matrix_final(j，jj) <> "" And jj <=sn
ReDim Preserve temp4rank(iterator)
temp4rank(iterator)=dis_m(gp_matrix_final(i，ii)，gp_matrix_final(j，jj))
iterator=iterator+1
jj=jj+1
Loop
ii=ii+1
Loop
min_val=smin(temp4rank)
dis_gp_matrix(i，j)=min_val
End If
Next j
Next i
Position=smin4m(dis_gp_matrix)
'更改gp_vec()賦值
gp_matrix_final=gp_merge(gp_matrix_final，sn，Position(1)，Position(2))
Loop Until UBound(gp_matrix_final) <=target_num
' 輸出基於每一分類平均水平最近的個股構成的向量
dist_2g=gp_matrix_final
End Function
Function gp_merge(gp_matrix As Variant，sn As Variant，a As Variant，b As Variant) As Variant
Dim gp_matrix_temp()
ReDim gp_matrix_temp(UBound(gp_matrix)-1，sn)
ii=1 'temp矩陣的行迭代器
Fori=1 To UBound(gp_matrix) 'i為原始矩陣行迭代器
If i=a Then
jjj=1
Forjj=1 To sn 'jj為temp矩陣的列迭代器，此處jj與j的部分功能一致,有理解上的麻煩
If gp_matrix(i，jj) <> "" Then
gp_matrix_temp(ii，jj)=gp_matrix(i，jj)
Else
gp_matrix_temp(ii，jj)=gp_matrix(b，jjj)
jjj=jjj+1
End If
Next jj
ii=ii+1
ElseIf i=b Then
Else '普通情況就複製
Forj=1 To sn 'j為gp_matrix的列迭代器