VBA数値計算用最新マクロ（常時更新）

当サイトの VBA 数値計算用マクロのなかには複数の Function Macro を参照するものがあります。以下のコードは当サイトのマクロを確実に動作させるための基幹ライブラリです。このページは新たにライブラリが追加されるごとに更新されます。最新記事のマクロを使用するにあたっては、コードをコピーし直してモジュールに上書きするようにしてください。なお、この基幹ライブラリが必要なマクロを掲載する場合は、その都度注意書きが掲載されます。そのような注意書きが載っていない記事にあるマクロは単独で使用できます。

Option Base 1

Dim pi As Double
Dim i As Integer, j As Integer

'複素数型変数の定義
Type Complex
re As Double
im As Double
End Type

'ガウスの超幾何関数
Function GHGEO(a As Double, b As Double, c As Double, _
x As Double) As Double
Dim fact As Long
Dim s As Double
d = a * b / c
s = 1 + d * x
For k = 2 To 100
d = d * (a + k - 1) * (b + k - 1) / (c + k - 1) / k
s = s + d * x ^ k
Next k
GHGEO = s
End Function

'合流超幾何級数
Function CHGEO(a As Double, c As Double, x As Double) As Double
Dim d As Double
Dim s As Double
d = a * x / c
s = 1 + d
For k = 1 To 200
d = d * x * (a + k) / (c + k) / (k + 1)
s = s + d
Next k
CHGEO = s
End Function

'複素変数の合流超幾何関数
Function CXCHGEO(a As Double, c As Double, z As Complex) As Complex
Dim d As Double
Dim k As Double
Dim s As Complex
Dim zk As Complex
d = a / c
s.re = 1 + d * z.re
s.im = d * z.im
zk = z
For k = 2 To 100
d = d * (a + k - 1) / (c + k - 1) / k
zk = CPXCLC(zk, z, 3)
s.re = s.re + d * zk.re
s.im = s.im + d * zk.im
Next k
CXCHGEO = s
End Function

'ラゲール陪多項式
Function LAG(n As Integer, k As Integer, x As Double)
nfact = WorksheetFunction.fact(n)
kfact = WorksheetFunction.fact(k)
nkfact = WorksheetFunction.fact(n - k)
LAG = (-1) ^ k * nfact ^ 2 * CHGEO(k - n, k + 1, x) / kfact / nkfact
End Function

'第1種不完全ガンマ関数
Function INCGMA(a As Double, z As Complex) As Complex
Dim za As Complex
Dim mz As Complex
Dim zada As Complex
Dim fz As Complex
za = CXPOWER(z, CPX(a, 0))
zada = CPXCLC(za, CPX(a, 0), 4)
mz = CPXCLC(CPX(-1, 0), z, 3)
fz = CXCHGEO(a, a + 1, mz)
INCGMA = CPXCLC(zada, fz, 3)
End Function

'第2種不完全ガンマ関数
Function INCGMA2(a As Double, z As Complex) As Complex
Dim k As Integer
Dim gmaa As Double
Dim zk As Complex
Dim ck As Complex, dk As Complex
Dim s As Complex, logz As Complex
Dim cpxgmaa As Complex
If a = 0 Then
logz = CXLOG(z)
s.re = -gm - logz.re + z.re
s.im = -logz.im + z.im
ck.re = -z.re
ck.im = -z.im
For k = 2 To 100
dk = CPXCLC(CPX((1 - k) / k ^ 2, 0), z, 3)
ck = CPXCLC(dk, ck, 3)
s.re = s.re - ck.re
s.im = s.im - ck.im
Next k
INCGMA2 = s
Else
gmaa = WorksheetFunction.Gamma(a)
cpxgmaa = CPX(gmaa, 0)
INCGMA2 = CPXCLC(cpxgmaa, INCGMA(a, z), 2)
End If
End Function

'指数積分関数 Ei(x)
Function EI(x As Double) As Double

Dim d As Double, k As Double, s As Double
Dim z1 As Complex, mz As Complex
Dim gmz As Complex, mgmz As Complex

'x が小さいところでは不完全ガンマ関数を用います
If x <= 50 Then

z1.re = x
z1.im = 0

'-z
mz = CPXCLC(CPX(-1, 0), z1, 3)

'Γ(0,-z)
gmz = INCGMA2(0, mz)

'-Γ(0,-z)
mgmz = CPXCLC(CPX(-1, 0), gmz, 3)

EI = mgmz.re

'x が大きいところでは漸近展開を用います
Else

d = 1
s = 1

For k = 1 To 10

d = d * k / x

s = s + d

Next k

EI = s * exp(x) / x

End If

End Function

'余弦積分
Function CI(x As Double) As Double

Dim p As Double, q As Double, r As Double
Dim h As Double, s As Double, gm As Double
Dim m As Integer, k As Integer

gm = 0.5772156649

m = 100
h = x / (2 * m)

s = (Cos(h) - 1) / h + (Cos(2 * h) - 1) / (2 * h)

For k = 1 To m - 1
p = 2 * k * h

q = (2 * k + 1) * h

r = (2 * k + 2) * h

s = s + (Cos(p) - 1) / p + 4 * (Cos(q) - 1) / q + (Cos(r) - 1) / r

Next k

CI = gm + Log(x) + s * h / 3

End Function

'正弦積分
Function SI(x As Double) As Double

Dim p As Double, q As Double, r As Double
Dim h As Double, s As Double
Dim m As Integer, k As Integer

m = 100
h = x / (2 * m)

s = 1 + Sin(h) / h + Sin(2 * h) / (2 * h)

For k = 1 To m - 1

p = 2 * k * h

q = (2 * k + 1) * h

r = (2 * k + 2) * h

s = s + Sin(p) / p + 4 * Sin(q) / q + Sin(r) / r

Next k

SI = s * h / 3

End Function

'エルミート多項式
Function HMT(n As Integer, x As Double, _
Optional unx As Boolean = False) As Double
Dim sqpi As Double
Dim k As Double
sqpi = Sqr(4 * Atn(1))
nfact = WorksheetFunction.fact(n)
k = 1 / Sqr((sqpi * 2 ^ n * nfact))
If n = 0 Then
HMT = 1
ElseIf n = 1 Then
HMT = 2 * x
ElseIf n Mod 2 = 0 Then
p = n / 2
pfact = WorksheetFunction.fact(p)
pfact2 = WorksheetFunction.fact(2 * p)
HMT = (-1) ^ p * pfact2 * CHGEO(-p, 0.5, x ^ 2) / pfact
Else
p = n \ 2
pfact = WorksheetFunction.fact(p)
pfact2 = WorksheetFunction.fact(2 * p + 1)
HMT = (-1) ^ p * pfact2 * x * CHGEO(-p, 1.5, x ^ 2) / pfact
End If
If unx = True Then
HMT = k * HMT * exp(-x ^ 2 / 2)
End If
End Function

'複素数の定義
Function CPX(a As Double, b As Double) As Complex
CPX.re = a
CPX.im = b
End Function

'極形式の複素数
Function CPX2(x As Double, Optional a As Double = 1) As Complex
CPX2.re = a * Cos(x)
CPX2.im = a * Sin(x)
End Function

'共役複素数
Function CJG(z As Complex) As Complex
CJG.re = z.re
CJG.im = -z.i
End Function

'複素数の絶対値
Function CPXABS(z As Complex, _
Optional s As Boolean = True) As Double
CPXABS = z.re ^ 2 + z.im ^ 2
If s = True Then
CPXABS = Sqr(CPXABS)
End If
End Function

'複素数の演算
Function CPXCLC(z1 As Complex, z2 As Complex, _
Optional s As Integer = 1) As Complex
Dim k As Double
Dim z As Complex
Select Case s
Case 1
z.re = z1.re + z2.re
z.im = z1.im + z2.im
Case 2
z.re = z1.re - z2.re
z.im = z1.im - z2.im
Case 3
z.re = z1.re * z2.re - z1.im * z2.im
z.im = z1.re * z2.im + z1.im * z2.re
Case Else
k = z2.re ^ 2 + z2.im ^ 2
z.re = (z1.re * z2.re + z1.im * z2.im) / k
z.im = (z1.im * z2.re - z1.re * z2.im) / k
End Select
CPXCLC = z
End Function

'複素平面上の2点間の距離
Function CPXD(z1 As Complex, z2 As Complex, _
Optional s As Boolean = True) As Double
CPXD = (z1.re - z2.re) ^ 2 + (z1.im - z2.im) ^ 2
If s = True Then
CPXD = Sqr(CPXD)
End If
End Function

'複素変数の指数関数
Function CEXP(z As Complex) As Complex
CEXP.re = exp(z.re) * (Cos(z.im))
CEXP.im = exp(z.re) * (Sin(z.im))
End Function

'偏角を計算
Function CPXARG(z As Complex, _
Optional s1 As Boolean = False, _
Optional s2 As Boolean = False) As Double
pi = 4 * Atn(1)
Select Case s1
'範囲を0～2πにする場合（初期設定ON）
Case False
If z.re = 0 And z.im > 0 Then
CPXARG = pi / 2
ElseIf z.re = 0 And z.im < 0 Then
CPXARG = 3 * pi / 2
ElseIf z.re < 0 And z.im = 0 Then
CPXARG = pi
ElseIf z.re > 0 And z.im >= 0 Then
CPXARG = Atn(z.im / z.re)
ElseIf z.re < 0 And z.im <> 0 Then
CPXARG = Atn(z.im / z.re) + pi
ElseIf z.re > 0 And z.im < 0 Then
CPXARG = Atn(z.im / z.re) + 2 * pi
End If
'範囲を-π～πにする場合（初期設定ON）
Case Else
If z.re = 0 And z.im > 0 Then
CPXARG = pi / 2
ElseIf z.re = 0 And z.im < 0 Then
CPXARG = -3 * pi / 2
ElseIf z.re < 0 And z.im = 0 Then
CPXARG = -pi
ElseIf z.re > 0 Then
CPXARG = Atn(z.im / z.re)
ElseIf z.re < 0 And z.im > 0 Then
CPXARG = Atn(z.im / z.re) + pi
ElseIf z.re < 0 And z.im < 0 Then
CPXARG = Atn(z.im / z.re) - pi
End If
End Select
'角度の単位を度数単位にする場合（初期設定 OFF）
If s2 = True Then
CPXARG = 180 * CPXARG / pi
End If
End Function

'複素変数の対数関数(C)BlogCat
Function CXLOG(z As Complex, _
Optional s As Boolean = False) As Complex
Dim absz As Double
Dim argz As Double
Dim logz As Complex
Dim iargz As Complex
absz = CPXABS(z)
argz = CPXARG(z)
If s = True Then
argz = CPXARG(z, True)
End If
logz = CPX(Log(absz), 0)
iargz = CPXCLC(CPX(0, 1), CPX(argz, 0), 3)
CXLOG = CPXCLC(logz, iargz)
End Function

'複素数のベキ乗
Function CXPOWER(z As Complex, a As Complex, _
Optional s As Boolean = False) As Complex
Dim alogz As Complex
If z.re = 0 And z.im = 0 Then
CXPOWER = CPX(0, 0)
Else
alogz = CPXCLC(a, CXLOG(z), 3)
If s = True Then
alogz = CPXCLC(a, CXLOG(z, True), 3)
End If
CXPOWER = CEXP(alogz)
End If
End Function

'cosz
Function CXCOS(z As Complex) As Complex
Dim iz1 As Complex
Dim iz2 As Complex
Dim cz As Complex
iz1 = CPXCLC(CPX(0, 1), z, 3)
iz2 = CPXCLC(CPX(0, -1), z, 3)
cz = CPXCLC(CEXP(iz1), CEXP(iz2))
CXCOS = CPXCLC(cz, CPX(2, 0), 4)
End Function

'sinz
Function CXSIN(z As Complex) As Complex
Dim iz1 As Complex
Dim iz2 As Complex
Dim cz As Complex
iz1 = CPXCLC(CPX(0, 1), z, 3)
iz2 = CPXCLC(CPX(0, -1), z, 3)
cz = CPXCLC(CEXP(iz1), CEXP(iz2), 2)
CXSIN = CPXCLC(cz, CPX(0, 2), 4)
End Function

'tanz
Function CXTAN(z As Complex) As Complex
CXTAN = CPXCLC(CXSIN(z), CXCOS(z), 4)
End Function
Sub testa()
Dim x As Complex
x = CXCHGEO(1, 2, CPX(-1, 0))
Debug.Print x.re
End Sub

当サイトのマクロの著作権は全て「あとりえこばと」に帰属します。
利用は個人的な目的に限って許可されます。
商用・非商用に関わらず、２次配布は禁止します。