もう１年程前になりますが、コマンドバーに登録したアドイン関数実行マクロがエラーになるという案件がありました。ATPVBAEN.XLA（分析ツール - VBA）の XIRR 関数です。
標準モジュールから実行すると問題ないのですが、CommandBars.Controls の OnAction に登録して実行するとエラー結果を返します。
その時は Application.OnTime メソッドを使って一応の解決を見ました。
Control のイベントなどから呼び出したマクロが上手くいかない場合、
Application.OnTime Now, "マクロ名"
...とやって、一旦呼び出したマクロを終了させた後に標準モジュールに置いたマクロに引渡すと、上手くいく場合があります。ましてこのケースは標準モジュールで実行するとエラーが出ないという事でしたので、それで結果オーライだったわけですね。
今回、前述した Application.OnTime メソッドの効用について記事を書こうと思い、古いログを引っ張り出して、違う角度から検証してみると、他にも要因があったのでは？と思い至りました。
以下は検証用コードです。
（[win2000sp4/xl2000sp3][winXPsp2/xl2003sp3]の環境で稼動確認してますが、もし試される場合は自己責任でお願いしますね）
コード内容は、[分析ツール - VBA]のアドインを登録し、ユーザー設定 CommandBar を追加し、５つのテストプロシージャを Control に登録するものです。
Temporary:=True にしていますから、Excel を終了すれば CommandBar は破棄されます。
一応削除用の Control も最後に追加してあります。
アドインの ATPVBAEN.XLA が見つからないというエラーが出る場合は、手動で[分析ツール - VBA]アドインをチェックしてください。
また、一部 ActiveSheet の値を書き換えますので気をつけてください。
Option Explicit
Const barName = "XIRRテスト"
Const str1 = "-10000000,2750000,4250000,3250000,2750000"
Const str2 = "1998/1/1,1998/3/1,1998/10/30,1999/2/15,1999/4/1"
'-------------------------------------------------
'コマンドバー削除
Sub DeleteMenuBar()
On Error Resume Next
Application.CommandBars(barName).Delete
'必要なければ後で手動でAddIn撤去してください。
'Application.AddIns("分析ツール - VBA").Installed = False
On Error GoTo 0
End Sub
'-------------------------------------------------
'コマンドバー作成表示
Sub MakeMenuBar()
Dim i As Long
Call DeleteMenuBar
Application.AddIns("分析ツール - VBA").Installed = True
With Application.CommandBars.Add(Temporary:=True)
.Name = barName
.Position = msoBarTop
.Visible = True
For i = 1 To 5
With .Controls.Add(Type:=msoControlButton)
.Style = msoButtonIconAndCaption
.OnAction = "xirrTest" & i
.Caption = "xirrTest" & i
.FaceId = 2950
End With
Next
With .Controls.Add(Type:=msoControlButton)
.Style = msoButtonIconAndCaption
.OnAction = "DeleteMenuBar"
.Caption = "閉じる"
.FaceId = 1019
End With
End With
End Sub
'-------------------------------------------------
Sub xirrTest1() '元の問題コード（当時のものからちょっと修正あり）
Dim ary1() As Variant
Dim ary2() As Variant
Dim varRet As Variant
Dim i As Long
Dim v1, v2
v1 = Split(str1, ",")
v2 = Split(str2, ",")
ReDim ary1(0 To UBound(v1))
ReDim ary2(0 To UBound(v2))
For i = 0 To UBound(v1) '金額
ary1(i) = CDec(v1(i))
Next i
For i = 0 To UBound(v2) '日付
ary2(i) = CDate(v2(i)) '■
Next i
varRet = Application.Run("atpvbaen.xla!xirr", ary1, ary2)
If Not IsError(varRet) Then
MsgBox CDec(varRet)
Else
MsgBox CStr(varRet)
End If
End Sub
'-------------------------------------------------
Sub xirrTest2() '一応これで解決
Application.OnTime Now, "xirrTest1"
End Sub
'-------------------------------------------------
Sub xirrTest3() 'CDate(v2(i))なし
Dim ary1() As Variant
Dim ary2() As Variant
Dim varRet As Variant
Dim i As Long
Dim v1, v2
v1 = Split(str1, ",")
v2 = Split(str2, ",")
ReDim ary1(0 To UBound(v1))
ReDim ary2(0 To UBound(v2))
For i = 0 To UBound(v1) '金額
ary1(i) = CDec(v1(i))
Next i
For i = 0 To UBound(v2) '日付
ary2(i) = v2(i)
Next i
varRet = Application.Run("atpvbaen.xla!xirr", ary1, ary2)
If Not IsError(varRet) Then
MsgBox CDec(varRet)
Else
MsgBox CStr(varRet)
End If
End Sub
'-------------------------------------------------
Sub xirrTest4() '簡略版
Dim ary1 As Variant
Dim ary2 As Variant
Dim varRet As Variant
ary1 = Split(str1, ",")
ary2 = Split(str2, ",")
varRet = Application.Run("atpvbaen.xla!xirr", ary1, ary2)
If Not IsError(varRet) Then
MsgBox CDec(varRet)
Else
MsgBox CStr(varRet)
End If
End Sub
'-------------------------------------------------
Sub xirrTest5() 'セル経由
Dim varRet As Variant
Range("A1:E1").Value = Split(str1, ",")
Range("A2:E2").Value = Split(str2, ",")
varRet = Application.Run("atpvbaen.xla!xirr", Range("A1:E1"), Range("A2:E2"))
If Not IsError(varRet) Then
MsgBox CDec(varRet)
Else
MsgBox CStr(varRet)
End If
End Sub
xirrTest1 のみ、エラーになります。
これは Application エラーではなく、XIRR 関数がエラー値を返すという事です。
他のテスト結果。
xirrTest3, xirrTest4, xirrTest5 は XIRR 関数へ渡す引数を少しずつ変えてあります。
結論としては、xirrTest1 の引数に
>ary2(i) = CDate(v2(i)) '■
ここで Date 型の配列を渡している事が原因のようです。
Application.OnTime メソッドを使わなくても良かったという事ですね...
ただ、標準モジュールだとエラーにならない理由は相変わらずナゾのまま......orz
