ADOで算術型のRound関数を使いたい

質問

お世話になっております。
ACCESSではRound関数を使うと銀行型で計算してしまうので、算術型で計算するため以下のような定義関数をACCESS上で作成しました。

Public Function Round(X As Currency, s As Integer) As Currency
Dim t As Integer
t = 10 ^ Abs(s)
If s > 0 Then
Round = Int(X * t + 0.5) / t
Else
Round = Int(X / t + 0.5) * t
End If
End Function

この関数を使えばACCESS上でクエリを見た時にはちゃんと算術型の計算結果が表示されるのですが、ADOを使ってExcelで読み込んだ時にはなぜか銀行型の計算結果が表示されていしまいます。

"Round"という関数名が良くなかったのかと思い、"Round2"という関数に変更したところ、ACCESS上は問題なかったのですが、ADOで読み込んだ時に"未定義の関数があります"とエラーが出てしまいました。

ADOで読み込んでも算術型のRound関数で計算するような方法はないでしょうか。

回答No.1

noname#140971

Q、ADOで算術型のRound関数を使いたい。
A、次のようにして使えないでしょうか？

[イミディエイト]
? DBLookup("SELECT Round(111.45, 1) FROM tab2")
111.4
? DBLookup("SELECT Round(111.55, 1) FROM tab2")
111.6
? DBLookup("SELECT Round(111.45 + 0.01, 1) FROM tab2")
111.5
? DBLookup("SELECT Round(111.55 + 0.01, 1) FROM tab2")
111.6
? DBLookup("SELECT fld_1 FROM tab2")
111.45
? DBLookup("SELECT Round(fld_1 + 0.01 * sgn(fld_1), 1) FROM tab2")
111.5

補足: 四捨五入関数は未完じゃないでしょうか？

上でも sgn関数を使っていますが、これを忘れるとトンデモない結果を得ると思いますよ。
質問者の関数と以下に示すRounds関数との実行結果の違いを確認されて下さい。

? Rounds(-5555.555, 0, 2)
-5555.56
? MyRound(5555.555, 2)
5555.56
? MyRound(-5555.555, 2)
-5555.55

なお、以下は、ADOでAccessのデータを参照するDBLookup関数と四捨五入、切り捨て、切り上げを行う関数です。
これらの関数で持って十分にテストを重ねられたがいいかもです。
ともかく、 Round(fld_1 + 0.01 * sgn(fld_1), 1)　なんてやり方は今考えたばかりだからです。

? Rounds(DBLookup("SELECT fld_1 FROM tab2"), 0, 2)
111.45
? Rounds(DBLookup("SELECT fld_1 FROM tab2"), 0, 1)
111.5

こういう結果と一致すれば、 Round(fld_1 + 0.01 * sgn(fld_1), 1)もバグっていません。
しかし、この検証は上述の一回だけのテスト。
そこは、質問者で行って下さい。

'
' ADO 接続文字列
'
Public Const pubCNNSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Temp\DB4.mdb"
'
' Rounds関数用
'
Public Const 四捨五入 = 0
Public Const 切り捨て = 1
Public Const 切り上げ = 2

Public Function DBLookup(ByVal strQuerySQL As String) As Variant
On Error GoTo Err_DBLookup
　　Dim DataValue
　　Dim rst As ADODB.Recordset

　　Set rst = New ADODB.Recordset
　　With rst
　　　　.Open strQuerySQL, _
　　　　　　 pubCNNSTRING, _
　　　　　　 adOpenStatic, _
　　　　　　 adLockReadOnly
　　　　If Not .BOF Then
　　　　　　.MoveFirst
　　　　　　DataValue = .Fields(0)
　　　　End If
　　End With
Exit_DBLookup:
On Error Resume Next
　　 rst.Close
　　 Set rst = Nothing
　　 DBLookup = DataValue
　　 Exit Function
Err_DBLookup:
　　 MsgBox "SELECT 文の実行時にエラーが発生しました。(DBLookup)" & Chr$(13) & Chr$(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr$(13) & _
　　　　　　"・SQL Text=" & strQuerySQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　 Resume Exit_DBLookup
End Function

Public Function Rounds(ByVal M As Currency, _
　　　　　　　　　　　 ByVal A As Integer, _
　　　　　　　　　　　 Optional D As Integer = 0) As Variant
　　　　Rounds = Sgn(M) * Fix(Abs(M) * 10 ^ D + Abs((A = 0) * 0.5@ + (A = 2) * (Int(M * 10 ^ D) <> (M * 10 ^ D)))) / 10 ^ D
End Function

Public Function MyRound(X As Currency, s As Integer) As Currency
　　Dim t As Integer

　　t = 10 ^ Abs(s)
　　If s > 0 Then
　　　　MyRound = Int(X * t + 0.5) / t
　　Else
　　　　MyRound = Int(X / t + 0.5) * t
　　End If
End Function