マガジン「EXCELでFX(外国為替)取引を楽しむ」で使ったマクロ(VBA)一覧
記事ではデータを使って一部しか検証していません。他にいろいろ試してみたい人のために記事で使ったエクセル用マクロ(VBA)や計算式をまとめてあります。
動作確認はOffice2019のエクセル上で行っています。また、検証しながらのコードなのできれいに整理されていない部分もあります。
グラフ化は基本、手動でその都度、完成していますが一部自動でグラフ化したマクロコードもあります。
マクロ付きエクセルファイルの供給は不安に思う方も多いので、コードとしてコピーしてマクロファイルを作成してください。
(参考) 新規のマクロファイル作成はメニューから
[開発]→左側にある[マクロ]→マクロ名を記入して[開始]をクリック
でマクロファイルが開きます。メニューに[開発]ボタンが表示されていない場合は
[ファイル]→[オプション]→[リボンのユーザー設定]→[開発]にチェック
で表示されるようになります。
■相関係数を使って為替相場見通しを予測してみた
A列 A1～ 基準データ
B列 B1～ 比較する全データ(基準データよりは多くなる)
C列 C1～ 相関係数の計算結果を出力
Sub CORR_SCAN()
Dim X, Y, NUM1, NUM2, N As Variant
Columns(3).Clear
'データ個数検出(A列,B列)
NUM1 = Cells(1, 1).End(xlDown).Row
NUM2 = Cells(1, 2).End(xlDown).Row
'ワークシート関数で相関曲線を計算しC列に出力
For i = 1 To (NUM2 - NUM1)
X = Range(Cells(1, 1), Cells(NUM1, 1))
Y = Range(Cells(i, 2), Cells(i + NUM1 - 1, 2))
Cells(i, 3) = WorksheetFunction.Correl(X, Y)
Next i
Cells(1.1).Select
End Sub上記の計算結果をE列～H列にその都度、数値でコピーし、J列にアルゴリズムの判断式を挿入しておく
D1セル 足切りの基準値(1未満)
E列 E1～ 1週間分の相関係数
F列 F1～ 2週間分の相関係数
G列 G1～ 3週間分の相関係数
H列 H1～ 4週間分の相関係数
J列 J1～ 以下の計算式を挿入
=IF(MIN(E1:H1)<D$1,0,E1*F1*G1*H1)使い方はD1セルの値を例えば「0.1」ステップずつ減少することにより相関関係が高い位置が抽出できます。
■多項式近似で為替相場見通しを予測してみた
近似式として３～６次までの「多項式近似」をマクロで書いていますが、一部変更することによりいろいろな近似式同士も比較することができます。
通常、マクロ設定ではグラフは手動設定で作図しませんが、ここではグラフが自動で出力されます。
xlPolynomial(多項式近似)
xlexponential(指数近似)
xllinear(線形近似)
xllogarithmic(対数近似)
xlmovingavg(移動平均)
xlpower(累乗近似)
Ａ列 A1～ 近似式を求めるためのデータ
Sub Polynomial()
Dim NUM As Integer
'A列のデータ数を検出し分散図を選択
NUM = Cells(1, 1).End(xlDown).Row
ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmooth).Select
ActiveChart.SetSourceData Source:=Range(Cells(1, 1), Cells(NUM, 1))
ActiveChart.FullSeriesCollection(1).Trendlines.Add
'近似式１
ActiveChart.FullSeriesCollection(1).Trendlines(1).Select
Selection.Format.Line.ForeColor.RGB = RGB(255, 0, 0)
With Selection
.Type = xlPolynomial
.Order = 3
End With
Selection.Backward = 5
'近似式２
ActiveChart.FullSeriesCollection(1).Trendlines.Add
ActiveChart.FullSeriesCollection(1).Trendlines(2).Select
Selection.Format.Line.ForeColor.RGB = RGB(0, 255, 0)
With Selection
.Type = xlPolynomial
.Order = 4
End With
Selection.Backward = 5
'近似式３
ActiveChart.FullSeriesCollection(1).Trendlines.Add
ActiveChart.FullSeriesCollection(1).Trendlines(3).Select
Selection.Format.Line.ForeColor.RGB = RGB(0, 0, 255)
With Selection
.Type = xlPolynomial
.Order = 5
End With
Selection.Backward = 5
'近似式４
ActiveChart.FullSeriesCollection(1).Trendlines.Add
ActiveChart.FullSeriesCollection(1).Trendlines(4).Select
Selection.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
With Selection
.Type = xlPolynomial
.Order = 6
End With
Selection.Backward = 5
ActiveChart.ChartTitle.Text = "多項式近似：3次(赤)4,次(緑),5次(青),6次(黒)"
Cells(1,1).Select
End Subコード自体は変更がしやすいように近似式を4個そのまま、書いています。
近似式の場合、一般にはA列にｘデータ、Ｂ列にｙデータを記入しますが、為替の場合、時間なのであまり意味がありません。そこでｘデータは省略しています。省略した場合、ｘデータは１，２，３・・・と言うように自動的に設定されます。
もし、ｘデータを省略しない場合は
Ａ列 A1～ 数値データ(ｘ)
Ｂ列 B1～ 数値データ(ｙ)
として、コードを以下のように変更してください。
ActiveChart.SetSourceData Source:=Range(Cells(1, 1), Cells(NUM, 2))■通貨ペアの相関を時間変数として評価してみる
最大通貨は9個までで、基準通貨と比較することができるのは8個にです。
通貨データは同数と言う前提で、通貨データ及び、通貨の種類の数は自動で検出します。
相関係数を計算するデータ長は最大データ数を1/4、2/4、3/4、4/4の長さでそれぞれ自動で計算します。例えばデータ長が100→(25、50、75、100)として計算します。
A列 A2～ 基準通貨データ、例えばUSD/JPY
B列～I列 B2～I2 比較する通貨データ
K列～R列 K2～R2 相関係数の計算結果
１行目 USD/JPYのように通貨名を記入
Sub Currency_Pair()
Dim NUM, NUM1, NUM2 As Integer
'データ数、通貨の数を検出(最大通貨数は9個)
Range(Columns(10), Columns(20)).Clear
NUM1 = Cells(1, 2).End(xlDown).Row
NUM2 = Cells(1, 2).End(xlToRight).Column
'相関係数を計算
Range(Cells(1, 2), Cells(1, NUM2)).Copy
Range(Cells(1, 11), Cells(1, 11 + NUM2)).PasteSpecial
Application.CutCopyMode = False
NUM1 = NUM1 - 1
For j = 1 To 4
If Int(NUM1 / 4) * j + 1 > NUM1 Then
NUM = NUM1
Cells(1 + j, 10) = NUM & "営業日"
Else
NUM = Int(NUM1 / 4) * j + 1
Cells(1 + j, 10) = NUM - 1 & "営業日"
End If
For i = 2 To NUM2
X = Range(Cells(2, 1), Cells(NUM, 1))
Y = Range(Cells(2, i), Cells(NUM, i))
Cells(1 + j, 9 + i) = WorksheetFunction.Correl(X, Y)
Next i
Next j
Cells(1, 1).Select
End Sub
■平日の曜日による為替変動を過去データから推測してみる
A列 A2～ 日付データ
B列 B2～ 高値データ
C列 C2～ 安値データ
1行目 各列の項目名
H列～N列 計算結果
コードが長くなってしまったため、一部は表示されてませんがスクロールで確認できます。
Sub Week()
Dim Ns, Ne, NUM､NN, VH, VL As Integer
Dim X(), Fri(2), Thu(2), Wen(2), Tue(2), Mon(2), LH(2, 5) As Integer
'最新の金曜日を検索
For i = 2 To 5
If WeekdayName(Weekday(Cells(i, 1)), True) = "金" Then
Ns = i
End If
Next i
'何週間あるか計算(1週間は5営業日で構成)
NUM = Cells(1, 2).End(xlDown).Row
NUM = Int((NUM - (Ns - 1)) / 5)
'各週毎の高値、安値の曜日確定
VH = 2 '高値の列番号
VL = 3 '安値の列番号
NN = NUM * 5
ReDim X(2, NN)
For j = 1 To NUM
For i = 0 To 4
If WorksheetFunction.Rank(Cells(Ns + i, VH), Range(Cells(Ns, VH), Cells(Ns + 4, VH)), 0) = 1 Then
X(1, 1 + i + (j - 1) * 5) = 1
Else
X(1, 1 + i + (j - 1) * 5) = 0
End If
If WorksheetFunction.Rank(Cells(Ns + i, VL), Range(Cells(Ns, VL), Cells(Ns + 4, VL)), 1) = 1 Then
X(2, 1 + i + (j - 1) * 5) = 1
Else
X(2, 1 + i + (j - 1) * 5) = 0
End If
Next i
Ns = Ns + 5
Next j
'曜日毎の初期化と集計
For i = 1 To 2
Fri(i) = 0
Thu(i) = 0
Wen(i) = 0
Tue(i) = 0
Mon(i) = 0
Next i
For j = 1 To 2
For i = 0 To NUM - 1
Fri(j) = Fri(j) + X(j, 1 + 5 * i)
Thu(j) = Thu(j) + X(j, 2 + 5 * i)
Wen(j) = Wen(j) + X(j, 3 + 5 * i)
Tue(j) = Tue(j) + X(j, 4 + 5 * i)
Mon(j) = Mon(j) + X(j, 5 + 5 * i)
Next i
Next j
'結果出力
Range(Columns(5), Columns(15)).Clear '出力画面をクリア
Cells(1, 9) = "高値"
Cells(1, 10) = "安値"
Cells(2, 8) = "金曜"
Cells(3, 8) = "木曜"
Cells(4, 8) = "水曜"
Cells(5, 8) = "火曜"
Cells(6, 8) = "月曜"
Cells(2, 9) = Fri(1)
Cells(3, 9) = Thu(1)
Cells(4, 9) = Wen(1)
Cells(5, 9) = Tue(1)
Cells(6, 9) = Mon(1)
Cells(2, 10) = Fri(2)
Cells(3, 10) = Thu(2)
Cells(4, 10) = Wen(2)
Cells(5, 10) = Tue(2)
Cells(6, 10) = Mon(2)
'金曜日が最高値
Erase LH
For i = 0 To NUM - 1
If X(2, 1 + 5 * i) > 0 And X(1, 1 + 5 * i) > 0 Then
LH(1, 1) = LH(1, 1) + 1
ElseIf X(2, 2 + 5 * i) > 0 And X(1, 1 + 5 * i) > 0 Then
LH(1, 2) = LH(1, 2) + 1
ElseIf X(2, 3 + 5 * i) > 0 And X(1, 1 + 5 * i) > 0 Then
LH(1, 3) = LH(1, 3) + 1
ElseIf X(2, 4 + 5 * i) > 0 And X(1, 1 + 5 * i) > 0 Then
LH(1, 4) = LH(1, 4) + 1
ElseIf X(2, 5 + 5 * i) > 0 And X(1, 1 + 5 * i) > 0 Then
LH(1, 5) = LH(1, 5) + 1
Else
End If
Next i
'木曜日が最高値
For i = 0 To NUM - 1
If X(2, 2 + 5 * i) > 0 And X(1, 2 + 5 * i) > 0 Then
LH(2, 2) = LH(2, 2) + 1
ElseIf X(2, 3 + 5 * i) > 0 And X(1, 2 + 5 * i) > 0 Then
LH(2, 3) = LH(2, 3) + 1
ElseIf X(2, 4 + 5 * i) > 0 And X(1, 2 + 5 * i) > 0 Then
LH(2, 4) = LH(2, 4) + 1
ElseIf X(2, 5 + 5 * i) > 0 And X(1, 2 + 5 * i) > 0 Then
LH(2, 5) = LH(2, 5) + 1
Else
End If
Next i
'結果出力
Cells(1, 13) = "最高値(金曜)"
Cells(1, 14) = "最高値(木曜)"
Cells(2, 12) = "金曜"
Cells(3, 12) = "木曜"
Cells(4, 12) = "水曜"
Cells(5, 12) = "火曜"
Cells(6, 12) = "月曜"
Cells(8, 12) = "全体週の数"
Cells(2, 13) = LH(1, 1)
Cells(3, 13) = LH(1, 2)
Cells(4, 13) = LH(1, 3)
Cells(5, 13) = LH(1, 4)
Cells(6, 13) = LH(1, 5)
Cells(3, 14) = LH(2, 2)
Cells(4, 14) = LH(2, 3)
Cells(5, 14) = LH(2, 4)
Cells(6, 14) = LH(2, 5)
Cells(1, 1).Select
End Sub■急落相場の戻り値をドル円相場で確認してみる
A列 A2～ 日付データ
B列 B2～ 始値データ
C列 C2～ 高値データ
D列 D2～ 終値データ
1行目 A1～D1 各列の項目名
変数 Vdown 急落条件(円)
変数 A 何日後のデータ比較
H1列～J7列 データ出力エリア
Sub Half_retrun()
Dim NUM, Vdown, A As Single
Dim X(), Y(), Sx(5), Sy(5) As Single
NUM = Cells(1, 1).End(xlDown).Row
ReDim X(5, NUM)
ReDim Y(5, NUM)
Erase Sx
Erase Sy
Vdown = 1.5 '下落金額
V33 = 1 / 3 '戻り率 1/3 33%
V50 = 1 / 2 '戻り率 1/2 50%
V66 = 2 / 3 '戻り率 2/3 66%
V100 = 1 / 1 '戻り率 1/1 100%
Range(Columns(8), Columns(10)).Clear
A = 3 '「A」日後の比較
'分類条件は下落金額
For i = 2 + A To NUM
If Cells(i, 2) - Cells(i, 4) > Vdown Then
'同日の始値と安値の差と戻り率で判断
If Cells(i, 5) - Cells(i, 4) > (Cells(i, 2) - Cells(i, 4)) * V66 Then
X(1, i) = 1
ElseIf Cells(i, 5) - Cells(i, 4) > (Cells(i, 2) - Cells(i, 4)) * V50 Then
X(2, i) = 1
ElseIf Cells(i, 5) - Cells(i, 4) > (Cells(i, 2) - Cells(i, 4)) * V33 Then
X(3, i) = 1
Else
X(4, i) = 1
End If
'{A}日後の高値と安値の差と戻り率で判断
If Cells(i - A, 3) - Cells(i, 4) >= (Cells(i, 2) - Cells(i, 4)) * V66 Then
Y(1, i) = 1
ElseIf Cells(i - A, 3) - Cells(i, 4) >= (Cells(i, 2) - Cells(i, 4)) * V50 Then
Y(2, i) = 1
ElseIf Cells(i - A, 3) - Cells(i, 4) >= (Cells(i, 2) - Cells(i, 4)) * V33 Then
Y(3, i) = 1
Else
Y(4, i) = 1
End If
Else
End If
Next i
'結果集計
For i = 1 + A To NUM
For j = 1 To 5
Sx(j) = Sx(j) + X(j, i)
Sy(j) = Sy(j) + Y(j, i)
Next j
Next i
For i = 1 To 4
Cells(i + 1, 9) = Sx(i)
Cells(i + 1, 10) = Sy(i)
Next i
Cells(6, 9) = Sx(1) + Sx(2) + Sx(3) + Sx(4)
Cells(6, 10) = Sy(1) + Sy(2) + Sy(3) + Sy(4)
Cells(2, 8) = "66以上%"
Cells(3, 8) = "50～65%"
Cells(4, 8) = "33～49%"
Cells(5, 8) = "33%未満"
Cells(6, 8) = "合計日数"
Cells(7, 8) = "下落金額(" & Vdown & "円以上)"
Cells(1, 9) = "同日"
Cells(1, 10) = A & "日後"
Cells(1, 1).Select
End Sub■為替相場の変動を周波数分析してみると周期性は見えてくるか
A列 A1～ 日付データ
B列 B2～ 繰り返し回数
C列 C1～ 発生確率の平均
D列 D2～ 1回目の発生確率(最新)
E列 E2～ 2回目の発生確率
・・・・・・・
FFT計算結果が出力されるD列以降の最後の行をk番とすると「k+2」行に
FFT複素出力、ｎ=1の偏角(位相)が表示されます。
FFTの特性上、Nfftの数値は4，8、16、32、64、128・・・・と言う数値を設定してください。
Sub FX_FFT_new()
'
Dim F() As String
Dim Nfft, Nscan, Nsum､N1, NUM As Double
'ワークシート関数名の短縮化
Dim Fx As WorksheetFunction: Set Fx = WorksheetFunction
Dim Ax As Worksheet: Set Ax = ActiveSheet
'初期設定
NUM = Cells(1, 1).End(xlDown).Row '使用最大データ数の確認
Nfft = 32
'FFTのポイント数(評価期間：営業日の日数)
N1 = Int(NUM / Nfft) '
ReDim F(Nfft) '
Nscan = Nfft / 2 '50%オーバーラップ(固定)
'ワークシート関数でFFT演算
Range(Cells(1, 2), Cells(4096, 4096)).Clear
For i = 1 To 2 * N1 - 1
Application.Run "ATPVBAEN.XLAM!Fourier", Ax.Range(Cells(1 + Nscan * (i - 1), 1), Cells(1 + Nscan * (i - 1) + Nfft - 1, 1)), Ax.Cells(1, i + 3), False, False
Next i
Range(Cells(Nscan + 1, 2), Cells(4096, 4096)).Clear
'n=1の位相を計算(解像度は10度単位になるように四捨五入)
For j = 1 To 2 * N1 - 1
Cells(Nscan + 2, j + 3) = Fx.Round((Fx.ImArgument(Cells(2, j + 3)) / Fx.Pi() * 180 + 360) Mod 360, -1)
Next j
'周波数の絶対値計算
For j = 1 To 2 * N1 - 1
For i = 1 To Nscan
Cells(i, j + 3) = Fx.ImAbs(Cells(i, j + 3))
Next i
Next j
'発生確率に変換
For j = 1 To 2 * N1 - 1
Nsum = Fx.Sum(Range(Cells(2, j + 3), Cells(Nscan, j + 3)))
Cells(1, j + 3) = Str(1 + Nscan * (j - 1))
For i = 2 To Nscan
Cells(i, j + 3) = Cells(i, j + 3) / Nsum
Next i
Next j
'周波数毎の平均化
Columns(3).Font.Bold = True
Cells(1, 3) = "平均 "
For i = 2 To Nscan
Cells(i, 3) = Fx.Average(Range(Cells(i, 4), Cells(i, 4 + 2 * N1 - 2)))
Next i
'繰り返し回数を表示
For i = 2 To Nscan
Cells(i, 2) = i - 1
Next i
'’処理に時間がかかるのでスペクトログラムをしたい場合は以下のコメント分をコードに変換してください
'’但し、十分に検証していないのと処理時間がフリーズしたように数十秒も掛かります。
'
''******** Spectrogram表示 *************
'
''グラフの削除
' With ActiveSheet
' For i = .ChartObjects.Count To 1 Step -1
' If .ChartObjects(i).Chart.ChartTitle.Text = "Spectrogram_STFT" Then
' .ChartObjects(i).Delete
' End If
' Next i
' End With
'
''スペクトグラム軸、グラフ作業エリアを設定
' Range(Cells(1, 4), Cells(1, 2 * N1 + 2)).Copy Destination:=Cells(Nscan + 4, 4)
' Range(Cells(2, 2), Cells(Nscan, 2)).Copy Destination:=Cells(Nscan + 5, 3)
' Range(Cells(Nscan + 5, 4), Cells(2 * Nscan + 3, 2 * N1 + 2)) = 1
'
''グラフ作画
' Range(Cells(Nscan + 4, 3), Cells(2 * Nscan + 3, 2 * N1 + 2)).Select
' ActiveSheet.Shapes.AddChart2(297, xlColumnStacked).Select
' ActiveChart.SetSourceData Source:=Range(Cells(Nscan + 4, 3), Cells(2 * Nscan + 3, 2 * N1 + 2))
' ActiveChart.ChartTitle.Text = "Spectrogram_STFT"
' ActiveChart.ChartGroups(1).GapWidth = 0
'
' For j = 1 To 2 * N1 - 1
' For i = 2 To Nscan
'
' ActiveChart.FullSeriesCollection(i - 1).Points(j).Select
' Call RGBcolor(Cells(i, j + 3), R, G, B)
'
' With Selection.Format.Fill
' .Visible = msoTrue
' .ForeColor.RGB = RGB(R, G, B)
' .Transparency = 0
' .Solid
' End With
'
' Next i
' Next j
'
' ActiveChart.Legend.Select
' Selection.Delete
'
' ActiveChart.Axes(xlValue).Select
' Selection.Delete
'
''********************************************
Cells(1, 1).Select
End Sub
スペクトログラム表示をする場合は以下のファンクションをVBAで上記マクロの後に貼り付けてください。
Function RGBcolor(ByVal x, ByRef R, ByRef G, ByRef B)
N = 60
If x < 1 / N Then
R = 0
G = 0
B = 255
ElseIf x < 2 / N Then
R = 0
G = 51
B = 255
ElseIf x < 3 / N Then
R = 0
G = 102
B = 255
ElseIf x < 4 / N Then
R = 0
G = 153
B = 255
ElseIf x < 5 / N Then
R = 0
G = 204
B = 255
ElseIf x < 6 / N Then
R = 0
G = 255
B = 255
ElseIf x < 6 / N Then
R = 0
G = 255
B = 204
ElseIf x < 7 / N Then
R = 0
G = 255
B = 204
ElseIf x < 8 / N Then
R = 0
G = 255
B = 153
ElseIf x < 9 / N Then
R = 0
G = 255
B = 102
ElseIf x < 10 / N Then
R = 0
G = 255
B = 51
ElseIf x < 11 / N Then
R = 0
G = 255
B = 0
ElseIf x < 12 / N Then
R = 51
G = 255
B = 0
ElseIf x < 13 / N Then
R = 102
G = 255
B = 0
ElseIf x < 14 / N Then
R = 153
G = 255
B = 0
ElseIf x < 15 / N Then
R = 204
G = 255
B = 0
ElseIf x < 16 / N Then
R = 255
G = 255
B = 0
ElseIf x < 17 / N Then
R = 255
G = 204
B = 0
ElseIf x < 18 / N Then
R = 255
G = 153
B = 0
ElseIf x < 19 / N Then
R = 255
G = 102
B = 0
Else
R = 255
G = 0
B = 0
End If
End Functionいいなと思ったら応援しよう！
