ExcelでSQLを使う-022 ソース公開-06 DLookup関数（Excel To Excel）
生後13日目。
仔犬たちは、移行期を迎えました。
尾っぽで喜怒哀楽を表現するようになりつつあります。
◇◇◇◇◇
６、色々と活躍するDLookup関数
マイクロソフトが推奨する《良いデータベースデザイン》の指針に従えば、表＜成績表＞のレイアウトは上図のようになります。
１、生徒名と科目名は、表＜生徒名簿＞と表＜科目一覧＞を参照する。
２、生徒名を縦軸、科目名を横軸にした表＜成績一覧＞はレポート関数で生成する。
というのがデータベース構築の流儀です。
テーブルは、データを「蓄積・保存」するための「表形式」のオブジェクトです 。・・・・・レポートは、テーブルから取り出したデータや集計結果などの「印刷画面」となるオブジェクトです。（https://allabout.co.jp/gm/gc/441947/）
冒頭の表＜成績表＞がAccessのテーブル。それを基に作成する表＜成績一覧＞が同レポートに相当するーAccessでは、そういう考え方です。
DLookup関数で＜生徒名＞と＜科目名＞を参照する
O07=DLookup("SELECT MAX(成績) FROM [成績表$C3:I100]
WHERE 種類='" &N4 & "' AND 科目名='" & N7 & "'")
O14=DLookup("SELECT MIN(成績) FROM [成績表$C3:I100]
WHERE 種類='" & N4 & "' AND 科目名='" & N14 & "'")
O21=DLookup("SELECT AVG(成績) FROM [成績表$C3:I100]
WHERE 種類='" & N4 &"' AND 科目名='" & N14 & "'")
DLookup関数で最高点得点者、最低点得点者を表示する
鈴木君と中村君にとっては歓迎されない仕組みですが、次は”期末試験”の科目別の最高得点と最低点を取った生徒名を表示しています。
O07=DLookup("SELECT 生徒名 FROM [成績表$C3:I100]
WHERE 種類='" & N4 & "' AND 科目名='" & N7 & "'
ORDER BY 成績 DESC", 1)
O14=DLookup("SELECT 生徒名 FROM [成績表$C3:I100]
WHERE 種類='" & N4 & "' AND 科目名='" & N7 & "'
ORDER BY 成績", 1)
DLookup関数は、２番目の引数で《該当する何番目のデータを取得するかを1以上の値で指定》することができますので、このように最高得点者の生徒名なども簡単に検索することができます。
DLookup関数
随分と前置きが長くなりましたが、次がDLookup関数です。もちろん、外部ブックも参照できます。
Public isEcho As Boolean
O07=DLookup("SELECT 生徒名 FROM [成績表$C3:I100]
WHERE 種類='" & N4 & "' AND 科目名='" & N7 & "'
ORDER BY 成績 DESC", 1)
O14=DLookup("SELECT 生徒名 FROM [成績表$C3:I100]
WHERE 種類='" & N4 & "' AND 科目名='" & N7 & "'
ORDER BY 成績", 1)
DLookup関数は、２番目の引数で《該当する何番目のデータを取得するかを1以上の値で指定》することができますので、このように最高得点者の生徒名なども簡単に検索することができます。
DLookup関数
随分と前置きが長くなりましたが、次がDLookup関数です。もちろん、外部ブックも参照できます。
Public isEcho As Boolean
Public Function DLookup(ByVal strSQL As String, _
Optional ByVal intSearch As Integer = 1, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True, _
Optional returnValue As Variant = "") As Variant
On Error GoTo Err_DLookup
'
' 【要参照設定】
'
' Micrsoft ActiveX Data Objects 2.8 Library
'
Dim R As Integer ' 行インデックス
Dim N As Integer ' 行総数 - 1
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strHDR As String
Dim varData
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
'
' ThisWorkbook.FullName の指定
'
If Len(xlFileName) = 0 Then
xlFileName = ThisWorkbook.FullName
End If
'
' 接続設定
'
With cnn
strHDR = IIf(isHeader, "HDR=YES", "HDR=NO")
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;" & strHDR & "IMEX=1;"
.Open xlFileName
'
' 列を読み込み
'
With rst
.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
If intSearch < 0 Then
intSearch = rst.RecordCount + intSearch + 1
End If
If Not .BOF Then
N = CInt(.RecordCount) - 1
intSearch = intSearch - 1
.MoveFirst
For R = 0 To N
If intSearch = R Then
varData = .Fields(0)
Exit For
End If
.MoveNext
Next R
End If
End With
End With
Exit_DLookup:
On Error Resume Next
rst.Close
Set rst = Nothing
DLookup = IIf(Len(varData & "") > 0, varData, returnValue)
Exit Function
Err_DLookup:
If isEcho Then
MsgBox "SELECT 文の実行時にエラーが発生しました。(DLookup)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_DLookup
End If
End Function
ExcelでSQLを使う-021: ソース公開-05 CircledText関数（共用）
新生児期の仔犬の排泄を促すのはママ犬の大切な役目です。
◇◇◇◇◇
５、囲み文字を自動付与するCircledText関数
SQL文に値をセットする場合には、データの種類によって決められた文字（囲み文字）で囲む必要があります。
Char ______"
Date ______#
String _____"
Integer ____なし
この問題を回避しないことには、エクセルで追加した顧客情報をAcessの[顧客台帳]に簡単にインサートすることはできません。
INSERT INTO 顧客台帳 (列リスト) VALUES (値リスト)
仮に、 (列リスト) VALUES (値リスト)を自動生成してくれる関数があれば助かります。
[イミディエイトウインドウ]
? DSelect("SELECT * FROM [Sheet4$B1:H11] WHERE ID=6",,,,,,False)
6;西島 英雄;にしじま ひでお;111134;東京都;墨田区;XX町
? CircledText("SELECT * FROM [Sheet4$B1:H11] WHERE ID=6", 1)
(ID,名前,読み,郵便番号,住所1,住所2,住所3) VALUES (6,'西島 英雄','にしじま ひでお','111134','東京都','墨田区','XX町')
次は、CircledText関数を用いてAccessの顧客台帳を更新するマクロです。
Sub Test06()
Dim I As Integer
Dim strDB As String
Dim strSelect As String
Dim strInsert As String
Dim strSQL As String
strDB = "D:\db1.mdb"
strSelect = "SELECT * FROM [Sheet4$B1:H11] WHERE ID=XXXXX"
strInsert = "INSERT INTO 顧客台帳 "
For I = 6 To 10
strSQL = Replace(strSelect, "XXXXX", I)
Call CnnExecute(strInsert & CircledText(strSQL, 1), strDB)
Next I
End Sub
注意1: トップの行以外を検索する時は、2番目の引数を指定
CircledText(strSQL, 2)____該当する行の最初から2番目
CircledText(strSQL, -2) ___該当する行の最後から2番目
注意2: AccessへInsertする場合は、3番目の引数<>0
X CircledText(strSQL)
O CircledText(strSQL,, -1)
CnnExecute関数でINSERT文を実行する強力な助っ人であるCircledText関数は、次のようです。
Public Function CircledText(ByVal strSQL As String, _
Optional ByVal intSearch As Integer = 0, _
Optional ByVal intForAccess As Integer = 0, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As String
On Error GoTo Err_CircledText
'
' 【要参照設定】
'
' Micrsoft ActiveX Data Objects 2.8 Library
'
Dim R As Integer
Dim N As Integer
Dim M As Integer
Dim strHDR As String
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strColList As String
Dim strValues As String
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
'
' ThisWorkbook.FullName の指定
'
If Len(xlFileName) = 0 Then
xlFileName = ThisWorkbook.FullName
End If
'
' 接続設定
'
With cnn
strHDR = IIf(isHeader, "HDR=YES", "HDR=NO")
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;" & strHDR & ";IMEX=1"
.Open xlFileName
'
' 列を読み込み
'
With rst
.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
N = CInt(.RecordCount)
If intSearch < 0 Then
intSearch = N + intSearch + 1
End If
If Not .BOF Then
strColList = "("
strValues = "("
intSearch = intSearch - 1
'
' MoveFirst
'
M = N - 1
For R = 0 To M
If intSearch = R Then
'
' データを呼び込む
'
For Each fld In .Fields
strColList = strColList & fld.Name & ","
If intForAccess = 0 Then
If Len(fld.Value & "") > 0 Then
Select Case fld.Type
Case 202 ' 文字列型
strValues = strValues & "'" & fld.Value & "',"
Case 3, 5 ' 数字型
strValues = strValues & fld.Value & ","
Case 6 ' 通貨型
strValues = strValues & fld.Value & ","
Case 7 ' 日付時刻型
strValues = strValues & "'" & fld.Value & "',"
Case Else
strValues = strValues & fld.Value & ","
End Select
Else
strValues = strValues & "null,"
End If
Else
If Len(fld.Value & "") > 0 Then
Select Case fld.Type
Case 202 ' 文字列型
strValues = strValues & "'" & fld.Value & "',"
Case 3, 5 ' 数字型
strValues = strValues & fld.Value & ","
Case 6 ' 通貨型
strValues = strValues & fld.Value & ","
Case 7 ' 日付時刻型
strValues = strValues & "#" & fld.Value & "#,"
Case Else
strValues = strValues & fld.Value & ","
End Select
Else
strValues = strValues & "null,"
End If
End If
Next fld
End If
.MoveNext
Next R
End If
End With
strColList = Left(strColList, Len(strColList) - 1)
strValues = Left(strValues, Len(strValues) - 1)
End With
CircledText = IIf(Len(strColList & "") > 0, strColList & ") VALUES " & strValues & ")", "")
Exit_CircledText:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Function
Err_CircledText:
MsgBox "SELECT 文の実行時にエラーが発生しました。(CircledText)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_CircledText
End Function
さて、CircledText関数の紹介記事を書いていて
＞あれっ、CnnExecute関数でUPDATE文を実行する強力な助っ人もいるのかな？
という疑問が湧きました。が、それは必要ない！で決着。で、予定通り、明日からは《Excel TO Excel》のSQLツールのソース公開編をスタートさせます。
※※※ 郵便番号の桁数 ※※※
単なる、テストデータの不備です。
ExcelでSQLを使う-020: ソース公開-04 DBWriter関数（Excel←→Access）
生後9日目。仔犬たちの爪を切りました。
専用爪切りよりも人間のが使いやすいようです。
４、DBSelect関数の結果を表示するDBWriter関数
今回のソース公開をキッカケに誕生したのが DBWriter関数。そもそもが、さほどの必要性を感じていませんでした。その理由は、DBSelect関数の結果をそのまんまシートに表示するなんてことはありえないーが、私の考え。でも、もしかしたら、エクセルのデータをAccessにエクスポートして、何らかの加工を施してからエクセルにインポートする向きもあるかも知れません。そういう例外的なケースでは、 DBWriter関数は重宝するかも知れません。
私が想定していた DBSelect関数の利用は、次のようです。
DBSelect関数は、B3に
|
3;鈴木 三郎;すずき さぶろう;0111132;東京都;世田谷区;XX町 |
||||
という値を読み込んでいます。
[イミディエイトウインドウ]
? CutStr("3;鈴木 三郎;すずき さぶろう;0111132;東京都;世田谷区;XX町", ";", 1)
3
? CutStr("3;鈴木 三郎;すずき さぶろう;0111132;東京都;世田谷区;XX町", ";", 2)
鈴木 三郎
後は、CutStr関数で各列の値を切り取って表示すれば、顧客台帳を[読み]で参照する仕組みが出来上がります。とは言っても・・・
＞全部、Accessの顧客台帳をシートに表示したい！
ケースは当然にあってしかるべきです。
Sub Accessの顧客台帳を表示する()
Dim strSQL As String
Dim strDB As String
strSQL = "SELECT * FROM 顧客台帳"
strDB = "D:\Db1.mdb"
Call DBWriter(strSQL, strDB, "New")
End Sub
ということで、急遽誕生したDBWriter関数は次のようです。
DBWriter関数
Public Function DBWriter(ByVal strSQL As String, _
ByVal strDB As String, _
ByVal strSheetName As String) As Boolean
On Error GoTo Err_DBMWriter
Dim isOK As Boolean
Dim strList As String
strList = DBSelect(strSQL, strDB, , "|", True, True)
isOK = SheetWriter(strList, strSheetName)
Exit_DBWriter:
DBMWriter = isOK
Exit Function
Err_DBWriter:
isOK = False
MsgBox "シート書き込み時にエラーが発生しました。(DBWriter)" & Chr(13)
Resume Exit_DBMWriter
End Function
DBWriter関数の役目は、ただ単に、DBSelect関数をコールえ、その結果をSheetWriter関数に渡すことです。ですから、シートへの書き込みは担当しているのは次のSheetWriter関数です。
SheetWriter関数
Public Const T__3FORMAT = "#,##0;-#,##0"
Public Const T__5FORMAT = "#,##0;-#,##0"
Public Const T__6FORMAT = "\#,##0;-\#,##"
Public Const T7_1FORMAT = "mm/dd"
Public Const T7_2FORMAT = "h:mm"
Public Const T202FORMAT = "@"
Public Const INTERIA_COLOR_0 = 15457460
Public Const INTERIA_COLOR_1 = 16115390
Public Const INTERIA_COLOR_2 = 16773320
Public Const FONT_NAME_0 = "MS P明朝"
Public Const FONT_SIZE_0 = 11
Public Const FONT_NAME_1 = "MS ゴシック"
Public Const FONT_SIZE_1 = 11
Public Function SheetWriter(ByVal strDataList As String, _
ByVal strSheetName As String) As Boolean
On Error GoTo Err_SheetWriter
Dim isOK As Boolean
Dim isNew As Boolean
Dim isAdd As Boolean
Dim H As Integer
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim M As Integer ' 行最大値
Dim R As Integer ' 行配列最大値
Dim C As Integer ' 列数
Dim WR As Integer
Dim WC As Integer
Dim WE As Integer
Dim strDatas() As String
Dim strValue As String
Dim strWriteName As String
Dim strTableName As String
Dim strOrigin As String
Dim intType() As Integer
Dim intSize() As Integer
Dim intLine() As Integer
Dim intColLength() As Integer
Dim intROffset As Integer
Dim intCOffset As Integer
Dim objWorksheet As Worksheet
isOK = True
Application.ScreenUpdating = False
' ***************************************
' データを配列変数に取り込む
' ***************************************
strDatas() = Split(strDataList, "|")
R = UBound(strDatas())
C = ChrCount(strDatas(0), ";") + 1
' ***************************************************************
' 各列のType等を格納する intType()等の配列宣言
' ***************************************************************
ReDim intType(C + 1)
ReDim intSize(C + 1)
ReDim intLine(C + 1)
' *******************************************
' 各列の最長バイト数を求める
' *******************************************
intColLength() = GetColLengthMax(strDatas())
' ***********************
' シートの初期化
' ***********************
isNew = CutStr(UCase(strSheetName), ";", 1) = "NEW"
If isNew Then
strWriteName = CutStr(UCase(strSheetName), ";", 2)
If Len(strWriteName) > 0 Then
Worksheets.Add.Name = strWriteName
Else
Worksheets.Add after:=Worksheets(Worksheets.Count)
strWriteName = Worksheets(Worksheets.Count).Name
End If
Else
strWriteName = CutStr(strSheetName, "$", 1)
strOrigin = CutStr(CutStr(CutStr(strSheetName, "$", 2), ":", 1), ";", 1)
End If
' ====================
' SET objWorksheet
' ====================
Set objWorksheet = ThisWorkbook.Worksheets(strWriteName)
' ************************************************
' intRowOffset, intColOffset を求める
' ************************************************
If strOrigin <> "" Then
intROffset = objWorksheet.Range(strOrigin).Row - 1
intCOffset = objWorksheet.Range(strOrigin).Column - 1
End If
' *************************************
' シートへの書き込みメイン
' *************************************
With objWorksheet
' ------------------------------
' シートのクリア
' ~~~~~~~~~~~~~~~~~~~~
' C=列数
' WC=書き込み開始列
' WE=書き込み終了列
'
' 上書: Call DBWriter(strSQL, "Sheet7$A1;OVER")
' : Call DBWriter(strSQL, "Sheet7$A1")
' : Call DBWriter(strSQL, "Sheet7$")
' 追加: Call DBWriter(strSQL, "Sheet7$A1;Add")
' : Call DBWriter(strSQL, "Sheet7$A1:Z100;Add")
' 消去: Call DBWriter(strSQL, "Sheet7$A1;Clear")
' : Call DBLWriter(strSQL, "New")
'
' M: 既存データの有効行数
'
strTableName = CutStr(UCase(strSheetName), ";", 1)
If Not isNew Then
Select Case CutStr(UCase(strSheetName), ";", 2)
Case "OVER"
isNew = True
Case "ADD"
If InStr(1, strTableName, ":") = 0 Then
'
' A1・・・H100 までをチェック
'
M = DLookup("SELECT Count(*)" & _
" FROM [" & strWriteName & "$" & _
strOrigin & ":" & _
MoveRange(strOrigin, 7) & "00]")
Else
'
' [シート名$A1:I100]の場合のチェック
'
M = DLookup("SELECT Count(*)" & _
" FROM [" & strTableName & "]")
End If
Case "CLEAR"
isNew = True: Worksheets(strWriteName).Cells.Clear
Case Else
isNew = True
End Select
End If
'
' 見出し部（追加以外は、描画）
'
If isNew Then
WR = 1 + intROffset
WC = 1 + intCOffset
WE = C + intCOffset
For I = WC To WE
K = K + 1
.Cells(WR, I) = CutStr(strDatas(0), ";", K)
.Cells(WR, I).HorizontalAlignment = xlCenter
.Cells(WR, I).Interior.Color = INTERIA_COLOR_0
.Cells(WR, I).Font.Name = FONT_NAME_0
.Cells(WR, I).Font.Size = FONT_SIZE_0
.Cells(WR, I).Font.Bold = True
Next I
End If
' ------------------------------
' 各列の Type 値を取得
' ------------------------------
For I = 1 To C
intType(I) = Val(CutStr(CutStr(strDatas(1), ";", I), ",", 1))
intSize(I) = Val(CutStr(CutStr(strDatas(1), ";", I), ",", 2))
intLine(I) = Val(CutStr(CutStr(strDatas(1), ";", I), ",", 3))
Next I
' -----------------------
' 列幅の設定
'
' WC: 書き込む列
' -----------------------
K = 0
For J = 1 To C
WC = J + intCOffset
.Columns(WC).ColumnWidth = (intColLength(K) + 3) * 1.13
K = K + 1
Next J
' ------------------------------------------
' 全行、全列をシートに書き込む
' ------------------------------------------
'
' (注意) %、分数、指数はサポートしていません！
'
' M: 行の最大値
' WR: 書き込み行 規定値は2（見出しがあるため）
' : 見出しは、《シートクリア》で出力している
' C: 列数
' WC: 書き込み位置
'
For I = 2 To R
' ---------------
' 書き込み
' ---------------
For J = 1 To C
strValue = CutStr(strDatas(I), ";", J)
'
' 書き込み位置の決定
'
WR = I + intROffset + M
WC = J + intCOffset
'
' 共通設定
'
.Cells(WR, WC).Font.Name = FONT_NAME_1
.Cells(WR, WC).Font.Size = FONT_SIZE_1
'
' タイプ別処理
'
Select Case intType(J)
Case 202
.Cells(WR, WC) = strValue
.Cells(WR, WC).NumberFormatLocal = T202FORMAT
Case 3
.Cells(WR, WC) = strValue
.Cells(WR, WC).NumberFormatLocal = T__3FORMAT
Case 5
.Cells(WR, WC) = strValue
.Cells(WR, WC).NumberFormatLocal = T__5FORMAT
Case 6
.Cells(WR, WC) = strValue
.Cells(WR, WC).NumberFormatLocal = T__6FORMAT
Case 7
.Cells(WR, WC) = strValue
If InStr(1, strValue, ":") = 0 Then
.Cells(WR, WC).NumberFormatLocal = T7_1FORMAT
Else
.Cells(WR, WC).NumberFormatLocal = T7_2FORMAT
End If
Case Else
.Cells(WR, WC) = strValue
.Cells(WR, WC).NumberFormatLocal = T202FORMAT
End Select
'
' １列目=№行は右詰めにする(念のため)
'
If J = 1 Then
.Cells(WR, WC).HorizontalAlignment = xlRight
End If
Next J
Next I
End With
Exit_SheetWriter:
On Error Resume Next
Set objWorksheet = Nothing
Application.ScreenUpdating = True
SheetWriter = isOK
Exit Function
Err_SheetWriter:
isOK = False
Resume Exit_SheetWriter
End Function
' =========================================
' aaa;bbb;ccc の各列の最長バイト数を求める
' =========================================
Public Function GetColLengthMax(ByRef strDatas() As String) As Integer()
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim l As Integer
Dim N As Integer
Dim M As Integer
Dim R() As Integer
N = UBound(strDatas())
M = ChrCount(strDatas(0), ";") + 1
ReDim R(M - 1)
For I = 0 To N
For J = 1 To M
K = J - 1
l = LenH(CutStr(strDatas(I), ";", J))
If l > R(K) Then
R(K) = l
End If
Next J
Next I
GetColLengthMax = R()
End Function
昨日、SQLWriter関数を参考に突貫工事で作成した二つの関数。テスト不足と認識していますが、公開しておきます。次は、【Excel←→Excel】のSQLツールのソース公開と予定していましたが、一つだけ公開漏れの関数がありました。明日は、ExcelからAccessのテーブルを更新する上で不可欠なXferLiteral関数を紹介することにします。
ExcelでSQLを使う-019: ソース公開-03 CnnExecute関数（Excel←→Access）
新生児期の中盤も過ぎて、仔犬たちの食欲（？）はますます盛ん。
黄色ちゃんと水色ちゃんの体重は、早くもIkgをオーバーしました。
文献によれば、体重が２倍になるのは2週齢頃。
が、３回共に1週齢と1日~2日で生誕時の倍の体重になっている。
◇◇◇◇◇
3、SQL文を実行するCnnExecutet関数
RunSQL メソッド (Access)
RunSQLメソッドは、Visual Basic で RunSQL アクションを実行します。
Access の DoCmd オブジェクトは RunSQLメソッドをサポートしています。CnnExecute関数は、RunSQLメソッドの類似品です。
【Access 標準ライブラリ】
Public Function CnnExecute(ByVal strSQL As String) As Boolean
On Error GoTo Err_CnnExecute
Dim isOK As Boolean
Dim cnn As ADODB.Connection
isOK = True
Set cnn = CurrentProject.Connection
With cnn
.Errors.Clear
.BeginTrans
.Execute strSQL
.CommitTrans
End With
Exit_CnnExecute:
On Error Resume Next
cnn.Close
Set cnn = Nothing
CnnExecute = isOK
Exit Function
Err_CnnExecute:
isOK = False
If cnn.Errors.Count > 0 Then
ErrMessage cnn.Errors(0), strSQL
cnn.RollbackTrans
Else
MsgBox "プログラムエラーが発生しました。" & _
"システム管理者に報告して下さい。(CnnExecute)", _
vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
End If
Resume Exit_CnnExecute
End Function
Public Sub ErrMessage(ByVal CnnErrors As ADODB.Error, ByVal strSQL As String)
MsgBox "ADOｴﾗｰが発生しましたので処理をｷｬﾝｾﾙします。" & Chr$(13) & Chr$(13) & _
"・Err.Description=" & CnnErrors.Description & Chr$(13) & _
"・Err.Number=" & CnnErrors.Number & Chr$(13) & _
"・SQL State=" & CnnErrors.SQLState & Chr$(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " ADO関数ｴﾗｰﾒｯｾｰｼﾞ"
End Sub
【Excel 標準ライブラリ】
Public Function CnnExecute(ByVal strSQL As String, _
ByVal strDB As String) As Boolean
On Error GoTo Err_CnnExecute
Dim isOK As Boolean
Dim DataValue
Dim cnn As Object
isOK = True
' ---------------
' Set
' ---------------
Set cnn = CreateObject("ADODB.Connection")
' ----------------------------------
' データベース オープン
' ----------------------------------
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB & ";"
With cnn
.Errors.Clear
.BeginTrans
.Execute strSQL
.CommitTrans
End With
Exit_CnnExecute:
On Error Resume Next
cnn.Close
Set cnn = Nothing
CnnExecute = isOK
Exit Function
Err_CnnExecute:
isOK = False
Debug.Print strSQL
If cnn.Errors.Count > 0 Then
ErrMessage cnn.Errors(0), strSQL
cnn.RollbackTrans
Else
MsgBox "プログラムエラーが発生しました。" & _
"システム管理者に報告して下さい。(CnnExecute)", _
vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
End If
Resume Exit_CnnExecute
End Function
ErrMessage関数の書き方は、AccessもExcelも一緒です。
エラー発生時には変更を破棄
（私の解釈では）CnnExcecute関数は、.BeginTransで処理を開始します。ただし、その処理はバッファ内で実行されて .CommitTrans でテーブルを更新します。エラー発生時には、.RollbackTrans が呼ばれバッファ内の処理は破棄されてテーブルは更新されることはありません。
CnnExecute関数の使用例_1
CnnExecute関数は、極論すれば僅か１行の関数。でも、使いようでは、強力な力を発揮します。例えば、同関数を用いて[成績表]に列[順位]を追加することもできます。
Sub Macro3()
Dim isOK As Boolean
Dim strSQL As String
Dim strDb As String
strSQL = "ALTER TABLE 成績表 ADD 順位 Int;"
strDb = "D:\Db1.mdb"
isOK = CnnExecute(strSQL, strDb)
If isOK Then
Message "ALTER TABLE を実行しました。"
End If
End Sub
CnnExecute関数の使用例_2
CnnExecute関数が真価を発揮するのは、成績表の順位を更新するなどの場合です。
Sub Macro4()
On Error GoTo Err_Macro4
Dim isOK As Boolean
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim intNewScore As Integer
Dim intNowScore As Integer
Dim intNowID As Integer
Dim intRowCount As Integer
Dim strSQL1 As String
Dim strSQL2 As String
Dim strDB As String
strSQL1 = "UPDATE 成績表 SET 順位=XXXXX WHERE ID=YYYYY"
strDB = "d:\Db1.mdb"
intRowCount = DBLookup("SELECT Count(*) FROM 成績表", strDB)
If intRowCount > 0 Then
K = 1
For I = 1 To intRowCount
J = J + 1
intNowID = DBLookup("SELECT ID FROM 成績表 ORDER BY 成績 DESC", strDB, I)
intNewScore = DBLookup("SELECT 成績 FROM 成績表 ORDER BY 成績 DESC", strDB, I)
If intNowScore <> intNewScore Then
K = J
intNowScore = intNewScore
End If
strSQL2 = Replace(strSQL1, "XXXXX", K)
strSQL2 = Replace(strSQL2, "YYYYY", intNowID)
isOK = CnnExecute(strSQL2, strDB)
If Not isOK Then
GoTo Err_Macro4
End If
Next I
End If
If isOK Then
Message "成績表を更新しました。"
End If
Exit_Macro4:
Exit Sub
Err_Macro4:
ErrorMsg "成績表の更新に失敗しました。"
Resume Exit_Macro4
End Sub
DBLookup関数の引数（何番目を取得するのか）を値渡しにしていて首尾よい結果を得られずに焦りましたが、何とか成績表の順位を更新できました。同点同位の処理がありますのでマクロが複雑になっています。しかし、かなり簡単に順位付けできたと思います。
次稿では DBWriter関数とSheetWriter関数を紹介します。
ExcelでSQLを使う-018: ソース公開-02 DBSelect関数（Excel←→Access）
５頭の仔犬は、体調抜群で順調に新生児期前半を過ごしています。
◇◇◇◇◇
２、Accessを参照するDBSelect関数
DBSelect関数も、1996年に書いた次の関数が原型です。
【Access ライブラリ関数】
Public Function DBSelect(ByVal strQuerySQL As String, _
Optional colDelimita As String = ";", _
Optional rowDelimita As String = ";") As String
On Error GoTo Err_DBSelect
Dim R As Integer ' 行インデックス
Dim N As Integer ' 行総数 - 1
Dim cnn As Object
Dim rst As Object
Dim fld As ADODB.Field
Dim strList As String ' 全てのデータを区切子で連結して格納
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
With rst
.Open strQuerySQL, _
CurrentProject.Connection, _
adOpenStatic, _
adLockReadOnly
If Not .BOF Then
N = .RecordCount - 1
.MoveFirst
For R = 0 To N
For Each fld In .Fields
With fld
strList = strList & .Value & colDelimita
End With
Next fld
strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
.MoveNext
Next R
Else
strList = ""
End If
End With
DBSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
Exit_DBSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Function
Err_DBSelect:
If isEcho Then
MsgBox "SELECT 文の実行時にエラーが発生しました。(DBSelect)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strQuerySQL, _
vbExclamation, " 関数エラーメッセージ"
End If
Resume Exit_DBSelect
End Function
Excel版DBSelect関数では For-Next文ではなくて Do-Loop Until() でデータを読み込んでいます。それは、ADOの.RecordCountの型がバージョンによって違うからです。型をキャストすれば For-Next文という手法を引き続き使えますが、今回は一般的なそれを採用しました。私的には、 For-Next文がスタック領域を使う（？）ので速いと思っています。
【Excel ライブラリ関数】
Public Function DBSelect(ByVal strSQL As String, _
ByVal strDB As String, _
Optional ByVal colDelimita As String = ";", _
Optional ByVal rowDelimita As String = ";", _
Optional ByVal withFieldInfo As Boolean = False, _
Optional ByVal withCounter As Boolean = False) As String
On Error GoTo Err_DBSelect
Dim cnn As Object
Dim rst As Object
Dim fld As Object
Dim intCounter As Integer
Dim strWhere As String
Dim strList As String
Dim strCountSQL As String
' ---------------
' Set
' ---------------
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' ----------------------------------
' データベース オープン
' ----------------------------------
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB & ";"
' ----------------------------------------
' レコードセット オープン
' ----------------------------------------
With rst
.Open strSQL, cnn
If Not .BOF Then
.MoveFirst
If withFieldInfo Then
'
' 列名を先頭に付与する
'
If withCounter = True Then
strList = "№" & colDelimita
End If
For Each fld In .Fields
strList = strList & fld.Name & colDelimita
Next fld
strList = strList & rowDelimita
strList = Replace(strList, colDelimita & rowDelimita, rowDelimita)
'
' 列タイプも先頭に付与する
'
If withCounter = True Then
strList = strList & "5" & colDelimita
End If
For Each fld In .Fields
strList = strList & fld.Type & colDelimita
Next fld
strList = strList & rowDelimita
strList = Replace(strList, colDelimita & rowDelimita, rowDelimita)
End If
'
' フィールドデータを読み込む
'
Do
intCounter = intCounter + 1
If withCounter = True Then
strList = strList & Format(intCounter,"0.00") & colDelimita
End If
For Each fld In .Fields
With fld
strList = strList & .Value & colDelimita
End With
Next fld
strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
.MoveNext
Loop Until (.EOF)
Else
strList = ""
End If
End With
Exit_DBSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
DBSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
Exit Function
Err_DBSelect:
MsgBox Err.Description
Resume Exit_DBSelect
End Function
DBSelect関数の使用例_1
次の例では、行区切り子に改行コード（Asccii Code 13）を指定しています。
Sub Macro1()
Dim strSQL As String
Dim strDB As String
strSQL = "SELECT * FROM [蔵書リスト] ORDER BY ID"
strDB = "D:\DB1.mdb"
Debug.Print DBSelect(strSQL, strDB, , Chr(13))
End Sub
DBSelect関数の使用例_2
本稿を書いている途中で急遽、DBSelect関数の結果をシートに書き出すDBWriter関数とSheetWriter関数を思い立ちました。そして、書き上げました。DBSelect関数を利用すれば、Accessのテーブルを丸ごとエクセルのシートにコピペする関数も容易に作成できます。
Public Function DBMWriter(ByVal strSQL As String, _
ByVal strDB As String, _
ByVal strSheetName As String) As Boolean
・・・・・
strList = DBSelect(strSQL, strDB, , "|", True, True)
isOK = SheetWriter(strList, strSheetName)
・・・・・
End Function
Sub Macro2()
Dim strSQL As String
Dim strDB As String
strSQL = "SELECT * FROM [蔵書リスト] ORDER BY ID"
strDB = "D:\DB1.mdb"
Call DBWriter(strSQL, strDB, "New")
End Sub
DBWriter関数は、DBSelect関数の結果をSheetWriter関数に渡すというたった２行の関数。SheetWriter関数は、受け取ったデータをただ単に書き出すというシンプルなもの。この両者については、次の次に紹介します。
ExcelでSQLを使う-017: ソース公開-01 DBLookup関数（Excel←→Access）
デイジー号が出産。三度目も5頭の仔犬でした。
なお、今回でママ犬は卒業します。
◇◇◇◇◇
１、Accessを参照するDBLookup関数
DBLookup関数の原型は1996年に書きました。いわゆる Access のDLookup関数の代替関数です。DLookup関数には、複雑なSQL文を書けないという制約があります。また、一目でSQL文がイメージできないという難点もあります。それを打破する目的で書いたものです。もちろん、そのままでは Excelから同関数を利用してAccessデータベースを参照することはできません。それを可能にしたのが２番目のDBLookup関数です。
【Access ライブラリ関数】
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, _
CurrentProject.Connection, _
adOpenStatic, _
adLockReadOnly
If Not .BOF Then
.MoveFirst
DataValue = .Fields(0)
End If
End With
Exit_DBLookup:
rst.Close
Set rst = Nothing
DBLookup = Nz(DataValue, ReturnValue)
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
【Excel ライブラリ関数】
Public isEcho As Boolean
Public Function DBLookup(ByVal strSQL As String, _
ByVal strDB As String, _
Optional ByVal intSearch As Integer = 1, _
Optional returnValue As Variant = "") As Variant
On Error GoTo err_DBLookup:
Dim isFound As Boolean
Dim R As Integer
Dim N As Integer
Dim M As Integer
Dim varData As Variant
Dim cnn As Object
Dim rst As Object
' ---------------
' Set
' ---------------
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' -------------------------------------
' データベース オープン
' -------------------------------------
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB & ";"
' ----------------------------------------
' レコードセット オープン
' ----------------------------------------
With rst
.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
N = CInt(.RecordCount)
If intSearch < 0 Then
intSearch = N + intSearch + 1
End If
If Not .BOF Then
intSearch = intSearch - 1
.MoveFirst
M = N - 1
For R = 0 To M
If intSearch = R Then
varData = .Fields(0)
isFound = True
Exit For
End If
.MoveNext
Next R
End If
End With
Exit_DBLookup:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
DBLookup = IIf(isFound, varData, returnValue)
Exit Function
err_DBLookup:
If isEcho Then
MsgBox Err.Description
End If
Resume Exit_DBLookup
End Function
DBLookup関数のエラーの表示・非表示を制御するのに広域な記号定数 isEcho を利用しています。
Sub SQLツールのエラー制御()
isEcho = Not isEcho
If isEcho Then
Message "SQLツールのエラーを常に表示します。"
Else
Message "SQLツールのエラーの表示を停止しました。" End If
End Sub
DBLookup関数の使用例_1
DBLookup関数の使い方は簡単です。例えば、Access のDB1.mdb の[蔵書リスト]を参照するには、次のように書きます。
DBLookup関数の使用例_2
DBLookup関数は、無駄に長くなった訳ではありません。例えば、次のような成績表から《成績順位を指定して[生徒名]を検索する》ことも出来ます。ドべは-1 を指示します。
DBLookup関数の使用例_3
また、DBLookup関数は、《該当するデータがなかった時の戻り値を指定できる》ので、次のような使用法もあります。このように、DBLookup関数を利用して、データの有無で'〇'や'×'あるいはヌル値を表示することもできます。
次回は、複数の行と複数の列を参照するDBSelect関数を紹介します。
閑話休題: WEB構築ツール
「南極物語」のオリジナルは、1983年（昭和58年）公開の日本映画。
犬係を演じたのは、高倉健。そのリメイク版「EIGHT BELOOW」では、ポール・ウォーカーが犬達の世話をする南極ガイドを好演。リメイク版でも、シベリアン・ハスキー犬が演じる犬達は、南極に置き去りにされる。そうして、彼らは、生き抜くために「想像を絶する過酷な（南極の）大自然」と闘い続ける。一度は、南極を去ったスタッフだが、チームを組んで犬の救出に向かう。そして、苦闘の果てに、両者は感動の再会を果たす。
映画「EIGHT BELLOW」のポスターで右から２番目のハスキー犬は、もしかしたら我が家の初代シベリアン・ハスキー犬と血が繋がっているのかも知れない。初代ハスキー犬マリー号の祖父母４頭、高祖父母８頭の全てがアメリカン・チャンピオン。彼らは、かなり有名な犬舎の出身である。事実、マリー号と同世代は、（当時）米国やカナダのWEBサイトで発見できた。その中の一頭が「EIGHT BELOOW」に登場していても、不思議ではないのだ。なお、出身犬舎については、「きら星達のレクエイムーシベリアン・ハスキー名犬物語」で詳細に紹介されている。
◇◇◇◇◇
WEBアプリ構築ツール。これは、かなり真剣に開発した。まず、最初に、JavaBeansの設計とクラス図を書いた。目的は、Java でのプログラミング作業ゼロでWEBサイトのデータベース管理アプリケーションを開発する環境を創り出すこと。
Function.Xfer は、DirectADOの働きには何の関係もない。JavaScript関数が送出するSQL文に書かれているテーブル名を実際のそれに翻訳するだけのもの。SQL文に書かれているテーブル名は、[顧客台帳]は[F1]などとなっているからだ。
今、見たら、一体、何が書かれているのかサッパリだ。まあ、数十頁にのぼる当時の開発記録を丹念に読み返したら、少しは記憶が戻ってくるかも知れない。
このようなクラスモジュールの設計が済んだら、それをBASIC言語流に記述する関数群の開発に取り組んだ。C言語に取り組んだ時も、A4で印刷したら厚さ15mm程度のライブラリの開発を先行させた。「記憶力に難がある」と自他ともに認める私には、これは必須の工程である。私は、BASIC言語流コードしか書けないのだ。
WEB開発ツールの実用化テスト
▲自作のMySQL WEB Client
これに恰好の題材が、MySQL WEB Client（=MySQL のコマンドラインツール）の自作。それを問題なく書けたら、WEB開発ツールとしての資格は十分だろうって判断だ。
DB管理ソフトでのJavaプログラミングはゼロ
ここまでの準備が整ったら、もはやDB管理ソフトと言えども、Javaでプログラミングする必要はない。サイトの各ページからJavaScript関数でSQL文をDirectDAOに送出するだけ。SQL文を受け取ったDirectDAOは、それを解析して DbManager に渡す。DbManegerは、データベースにアクセスしてテーブルをを変更、削除、あるいは参照して結果をDirectDAOに返す。DirectDAOは、呼び出し元のJavaScript関数に、それが求めるフォーマットに整形し、かつ、必要な情報を付加した戻り値の一群を返す。このJavaScript関数とDirectDAOの仲立ちをするのがAjaxシステム。
実際に、DB管理ソフトを開発してみる
これらは、口で言うだけではダメである。そこで、小さなデータベース管理ソフトの開発に着手。
Javaでのプログラミング工程がゼロだったから、一ヶ月で上図のようなこじんまりしたアプリケーションが完成した。と、同時に、勤務先の工場が閉鎖された。いわゆる、バブル経済崩壊の影響をモロに受けたということだ。私の VBA との付き合いも 1996年でジ・エンドになったのは、そんな事情による。
＞時代の逆風に晒された時には、如何なる個人の奮闘・努力も無力・無駄である！
この時ばかりは、心底にそう思った。
