ExcelでSQLを使う-029: ソース公開-13 DSWriter関数（Excel To Excel）
外敵から身を守る！そのために自分の巣穴では排泄しない。
この祖先の本能は、ラブラドール・レトリーバーにも引き継がれています。
2週齢に達した仔犬たちは、先祖の教えに従って産箱の外で排泄します。
◇◇◇◇◇
１１、検索結果をシートに書き出すDSWriter関数
DSWriter関数は、DSelect関数が実行したSQL文の検索データをエクセルのシートに書き出す関数です。検索データをピボットテーブルとして書き出すことができるSQLWriter関数の簡易バージョンです。両者の違いは、ピボットテーブルをサポートしていないことです。
Sub 売上データのクロス集計クエリ()
Dim strSQL As String
strSQL = "TRANSFORM Sum(金額) AS 金額の合計 " & _
"SELECT Format(販売日,'mm月度') AS 販売月, 品種, 商品, Sum(金額) AS [合計金額] " & _
"FROM [売上データ$A1:G100] " & _
"WHERE 品種='家電1' OR 品種='家電2' " & _
"GROUP BY Format(販売日,'mm月度'), 品種, 商品 " & _
"ORDER BY Format(販売日,'mm月度'), 品種, 商品 " & _
"PIVOT 部署;"
Call DSWriter(strSQL, "New")
End Sub
SQLWriter
DSWriter
SQLWriter関数とDSWriter関数の実行結果は、
１、総合計欄の有無
２、小集計欄の有無
３、総合計欄の位置
４、小集計見出しの非重複表示
の４つです。しかし、この差異を埋めるには、A4で20数頁のVBAコードを書く必要がありました。正に、両者は《似て非なる者》です。
Call DSWriter(strSQL, "New")
DSWriter関数は、DSelect関数が実行したSQL文の検索データを新しいシートに書き出すことができます。仮に、２番目の引数に不正な引数を指定すると、次のエラーを表示して実行を中止します。
Sub 成績表の一部を新しいシートにコピーする()
Dim strSQL As String
strSQL = "SELECT * FROM [成績表$D3:J100] " & _
"WHERE 種類='期末試験'"
Call DSWriter(strSQL, "New")
End Sub
Call DSWriter(strSQL, "Add")
DSWriter関数は、DSelect関数が実行したSQL文の検索データを既存のシートに追加することができます。
Sub 成績表の一部を既存のシートに追加する()
Dim strSQL As String
strSQL = "SELECT * FROM [成績表$D3:J100] " & _
"WHERE 種類='中間試験'"
Call DSWriter(strSQL, "Sheet10$A1:H100;Add")
End Sub
このように、DSWriter関数の書き込みには、
１、新規：Call DSWriter(SQL, "New"
２、追加：Call DSWriter(SQL, "SheeteName$XX:XX;ADD"
３、上書：Call DSWriter(SQL, "SheeteName$XX:XX;OVER"
４、消去：Call DSWriter(SQL, "SheeteName$XX:XX;CLEAR"
の４つのモードがあります。《上書》は、’期末試験’のみを再度書き込む際に利用します。クリア（消去）モードは、もう一度やり直す際に利用できます。
DSWriter関数
次は、DSWriter関数のソースコードです。表の＜行№＞が不要な場合には、６番目の引数に False を指定します。
Public Function DSWriter(ByVal strSQL As String, _
ByVal strSheetname As String, _
Optional ByVal intMeisaiField As Integer = 0, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True, _
Optional ByVal isRowNumber = True) As Boolean
On Error GoTo Err_DSWriter
Dim isOK As Boolean
Dim isPivot As Boolean
Dim intCount As Integer
Dim intOrigin As Integer
Dim strList As String
Dim strQuery As String
Dim strTableNow As String
Dim strTableNew As String
Dim strRangeName As String
' -------------------------------------------
' テーブル範囲のチェックと適正化
' -------------------------------------------
strSQL = UCase(strSQL)
strQuery = "SELECT COUNT(*) FROM [XXXXX]"
strTableNow = CutStr(CutStr(CutStr(strSQL, "FROM", 2), "[", 2), "]", 1)
'
' 有効行数の取得
'
' （注意）ヘッダー有りは1行多い！
'
strQuery = Replace(strQuery, "XXXXX", strTableNow)
intCount = DLookup(strQuery) + Abs(isHeader)
intOrigin = CInt(CutStr(GetRangeRow(strTableNow), ";", 1))
strRangeName = CutStr(GetRangeName(strTableNow), ";", 2)
strTableNew = CutStr(strTableNow, ":", 1) & ":" & _
strRangeName & _
intCount
strSQL = Replace(strSQL, strTableNow, strTableNew)
' --------------------------------
' DSelect関数のコール
' --------------------------------
strList = DSelect(strSQL, ";", "|", xlFileName, isHeader, isRowNumber)
If ChrCount(strList, "|") <> 0 Then
isOK = XLSWriter(strList, strSheetname, isRowNumber)
Else
isOK = False
End If
Exit_DSWriter:
DSWriter = isOK
Exit Function
Err_DSWriter:
isOK = False
MsgBox "実行時にエラーが発生しました。(DSWriter)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_DSWriter
End Function
XLSWriter関数
DSWriter関数は、ユーザが指示した表の範囲をチェックして実際のそれに変更します。その上でSQL文を実行してXLSWriter関数に検索で得たデータリストを渡します。次は、シートへの書き込みを担当しているXLSWriter関数のソースコードの全てです。なお、ADO Connection が関知する型は、増える可能性もあります。例えば、SQL文のCOUNT(*)の型は、Integer型でしたので最近追加したばかりです。
Public Const T__3FORMAT = "#,##0;-#,##0"
Public Const T__5FORMAT = "#,##0;-#,##0"
Public Const T__6FORMAT = "\#,##0;-\#,##"
Public Const T7_1FORMAT = "yyyy/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 XLSWriter(ByVal strDataList As String, _
ByVal strSheetname As String, _
ByVal isRowNumber As Boolean) As Boolean
On Error GoTo Err_XLSWriter
Dim StopNow As Boolean
Dim isOK As Boolean
Dim isNew As Boolean
Dim isAdd As Boolean
Dim isSubTotalRow As Boolean
Dim isMeisaiRow 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 = CBool(InStr(1, UCase(strSheetname), "NEW") > 0)
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), ";", 2)
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 DSWriter(strSQL, "New")
' 上書: Call DSWriter(strSQL, "Sheet7$A1;OVER")
' : Call DSWriter(strSQL, "Sheet7$A1")
' : Call DSWriter(strSQL, "Sheet7$")
' 追加: Call DSWriter(strSQL, "Sheet7$A1;Add")
' : Call DSWriter(strSQL, "Sheet7$A1:Z100;Add")
' 消去: Call DSWriter(strSQL, "Sheet7$A1;Clear")
'
' 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
ErrorMsg "シート名エラーが発生しました。" & Chr(13) & Chr(13) & _
"【シート名の指定要領】" & Chr(13) & Chr(13) & _
" 新規: Call DSWriter(strSQL, ""New"")" & Chr(13) & Chr(13) & _
" 上書: Call DSWriter(strSQL, ""Sheet7$A1;OVER"")" & Chr(13) & _
" : Call DSWriter(strSQL, ""Sheet7$A1"")" & Chr(13) & _
" : Call DSWriter(strSQL, ""Sheet7$"")" & Chr(13) & Chr(13) & _
" 追加: Call DSWriter(strSQL, ""Sheet7$A1;Add"")" & Chr(13) & _
" : Call DSWriter(strSQL, ""Sheet7$A1:Z100;Add"")" & Chr(13) & Chr(13) & _
" 消去: Call DSWriter(strSQL, ""Sheet7$A1;Clear"")"
StopNow = True
isOK = False
End Select
End If
If Not StopNow Then
'
' 見出し部（追加以外は、描画）
'
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)
If J = 1 And isRowNumber Then
strValue = str(Val(strValue) + M)
End If
'
' 書き込み位置の決定
'
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 If
End With
Exit_XLSWriter:
On Error Resume Next
Set objWorksheet = Nothing
Application.ScreenUpdating = True
XLSWriter = isOK
Exit Function
Err_XLSWriter:
isOK = False
Resume Exit_XLSWriter
End Function
getCollength関数
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
Public Function ChrCount(ByVal Text As String, _
ByVal C As String) As Integer
ChrCount = Len(Text & "") - Len(Replace(Text & "", C, ""))
End Function
Public Function LenH(ByVal Text As String) As Integer
LenH = LenB(StrConv(Text, vbFromUnicode))
End Function
これで、ソースの公開は一区切りとします。全体で30頁近いコードを持つSQLWriter関数のソースコードを「いつ、どのように？」は、今、検討を開始したばかりです。では、ちょいと充電期間に突入します。
ExcelでSQLを使う-028: ソース公開-12 DSelect関数（Excel To Excel）
移行期も後半。
仔犬たちの生活サイクルが徐々にはっきりしてきました。
《２時間ほど寝て30分ほど起きて、オッパイを飲んで遊んでまた寝る》
のサイクルが生まれつつあります。
◇◇◇◇◇
１０、複数行を検索するDSelect関数
一列のみを検索するDLookup関数、一行のみを検索するELookup関数、そして複数行を検索するDSelect関数。それぞれにそれぞれの利用方法があります。DSelect関数の一つの利用例は、〔生徒の成績確認フォーム〕のそれです。
〔生徒の成績確認フォーム〕とDSeelct関数
次の〔生徒の成績確認フォーム〕では、〔生徒_№〕を入力すると＜成績表＞から〔種類〕が’期末試験’の全科目の〔成績〕を検索して表示するようになっています。この仕掛けの中心的な役割りを担っているのがDSelect関数です。
1.00;1;鈴木 一郎;1:英語;30|
2.00;1;鈴木 一郎;2:数学;40|
3.00;1;鈴木 一郎;3:国語;50|
4.00;1;鈴木 一郎;4:理科;40|
5.00;1;鈴木 一郎;5:社会;30
B4は、上記のデータが一列に並んでいます。A6～A10の式では、その各行を取り出しています。
A06=CutStr(B4, "|",1)・・・1.00;1;鈴木 一郎;英語;30
A07=CutStr(B4, "|",2)・・・2.00;1;鈴木 一郎;数学;40
A08=CutStr(B4, "|",3)・・・3.00;1;鈴木 一郎;国語;50
A09=CutStr(B4, "|",4)・・・4.00;1;鈴木 一郎;理科;40
A10=CutStr(B4, "|",5)・・・5.00;1;鈴木 一郎;社会;30
注意を要するのは、DSelect関数は7番目の引数でFalseを指定しないと先頭に行カンターを付与するということです。ですから、次のように一つズラして必要なデータを取り出します。
? CutStr(A06, ";", 2)
1
? CutStr(A06, ";", 3)
鈴木 一郎
? CutStr(A06, ";", 4)
英語
? CutStr(A06, ";", 5)
30
DSelect関数のみを利用した場合の注意点：
DSelect関数は、データを全て文字列として取得します。そのため、上図のように〔生徒_№〕や〔成績〕が左詰めで表示されます。それを右詰表示するのは、関数ユーザーの役目になります。
＜成績表＞の選択クエリとDSelect関数
上図は、Accessの選択クエリを表示したものです。DSelect関数でも、同じ検索結果を得ることができます。マクロ《成績表の選択クエリ》では、DSelect関数の３番目の引数（行区切り子）に改行コードを指定しています。
Sub 成績表の選択クエリ()
Dim strSQL As String
strSQL = "SELECT DISTINCTROW " & _
"生徒_№, 名前, 科目, Avg(成績) AS 平均点, Min(成績) AS 最低点, Max(成績) AS 最高点 " & _
"FROM [成績表$D3:J100] " & _
"GROUP BY 生徒_№, 名前, 科目 " & _
"ORDER BY 生徒_№;"
Debug.Print DSelect(strSQL, , Chr(13))
End Sub
DSelect関数の検索結果をシートに反映するのは SQLWriter関数、DSWriter関数の役目です。SQLWriter関数は、ピボットテーブルを生成する完全版。DSWriter関数は、SQLWriter関数から小集計表示機能を省いた簡便バージョンです。
Sub 成績表の選択クエリ2()
Dim strSQL As String
strSQL = "SELECT DISTINCTROW " & _
"生徒_№, 名前, 科目, Avg(成績) AS 平均点, Min(成績) AS 最低点, Max(成績) AS 最高点 " & _
"FROM [成績表$D3:J100] " & _
"GROUP BY 生徒_№, 名前, 科目 " & _
"ORDER BY 生徒_№;"
Call SQLWriter(strSQL, "New")
End Sub
SQLWriterで描画
＜成績表＞のクロス集計クエリとDSelect関数
上図は、Accessのクロス集計クエリを表示したものです。DSelect関数でも、同じ検索結果を得ることができます。
Sub 成績表のクロス集計クエリ()
Dim strSQL As String
strSQL = "TRANSFORM FIRST(成績) AS 成績の先頭" & _
" SELECT 名前" & _
" FROM [成績表$D3:J100]" & _
" WHERE 種類='期末試験'" & _
" GROUP BY 名前" & _
" ORDER BY 名前, 科目" & _
" PIVOT 科目"
Call DSWriter(strSQL, "New")
End Sub
DSWriterで描画
英数国の順番に列を並べるのに科目名を修正しています。いわゆる小集計欄を持つピボットテーブルでなければ、SQLWriter関数で描いてもDSWriter関数で描いても結果は同じです。
本稿でみたように、選択クエリ、クロス集計クエリ、重複クエリ、不一致クエリを実行して結果を戻すDSelect関数のソースは、次のようです。
DSelect関数
Public Function DSelect(ByVal strSQL As String, _
Optional ByVal colDelimita As String = ";", _
Optional ByVal rowDelimita As String = "|", _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True, _
Optional ByVal withFieldInfo As Boolean = False, _
Optional ByVal withCounter As Boolean = True) As String
On Error GoTo Err_DSelect
'
' 【要参照設定】
'
' Micrsoft ActiveX Data Objects 2.8 Library
'
Dim isData As Boolean
Dim intCounter As Integer
Dim strHDR As String
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strData As String
Dim strList 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
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
'
' データチェック
'
strData = ""
For Each fld In .Fields
strData = strData & fld.Value
Next fld
isData = CBool(Len(strData) > 0)
'
' データ取得
'
If isData Then
intCounter = intCounter + 1
If withCounter = True Then
strList = strList & Format(intCounter, ".00") & colDelimita
End If
For Each fld In .Fields
strList = strList & fld.Value & colDelimita
Next fld
strList = Mid(strList, 1, Len(strList) - Len(colDelimita & "")) & rowDelimita
End If
.MoveNext
Loop Until (.EOF)
Else
strList = ""
End If
End With
End With
Exit_DSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
DSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
Exit Function
Err_DSelect:
If isEcho Then
MsgBox "SELECT 文の実行時にエラーが発生しました。(DSelect)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数エラーメッセージ"
End If
Resume Exit_DSelect
End Function
次のソース公開は、DSWriter関数です。
PS、エラー制御
DLookup関数、Elookup関数、DSelect関数を式に組み込んだ時は、広域変数 isEcho を真にしておくと、関連データを削除した際にエラーが表示されます。それが煩わしいので既定では、その値を偽にしていまっす。以下は、その真と偽とを切り替えるマクロです。
ExcelでSQLを使う-027: ソース公開-11 SQLExecute関数-3（Excel To Excel）
16日齢を迎えた仔犬の体重は、1.47g～1.64Kgに達しました。
飲むオッパイの量も増えました。
それにつれて、ママ犬のフード量も激増しています。
180g×3+90g=630gが一日のフード量。
ママ犬は、通常の2.86倍のフードを食べてオッパイを出しています。
◇◇◇◇◇
９、エクセルでSQL文を実行するSQLExecute関数
９－３、SQLExecute関数で表に行を追加する
まず、CircledText関数が、『大田区新規顧客リスト』をどのように読み込むのかを確認してみます。
CircleTextの1番目の引数: 実行するSQL文
CircleTextの2番目の引数: 戻り値にセットする行の番目
CircleTextの3番目の引数: Assessから読み込むかどうか？既定値はExcelブック
CircleTextの4番目の引数:読み込むDBないしExcelブック等のフルネーム
CircleTextの5番目の引数: ヘッダーの有無
Sub Macro7()
Dim strSQL As String
Dim strXLF As String
strSQL = "SELECT * FROM [Sheet1$A1:G100]"
strXLF = "D:\大田区新規顧客リスト.xlsx"
Debug.Print 1 & ": " & CircledText(strSQL, 1, , strXLF, False)
Debug.Print 2 & ": " & CircledText(strSQL, 2, , strXLF, False)
Debug.Print 3 & ": " & CircledText(strSQL, 3, , strXLF, False)
Debug.Print 4 & ": " & CircledText(strSQL, 4, , strXLF, False)
End Sub
[イミディエイトウインドウ]1: (F1,F2,F3,F4,F5,F6,F7) VALUES (125001,'裏山 登','うらやま のぼる',1111250,'東京都','大田区','TT町')
2: (F1,F2,F3,F4,F5,F6,F7) VALUES (125002,'川上 清','かわかみ きよし',1111250,'東京都','大田区','TT町')
3: (F1,F2,F3,F4,F5,F6,F7) VALUES (125003,'千原 宏','ちはら ひろし',1111250,'東京都','大田区','TT町')
4:
これだけわかれば、列名を書かないINSERT文で新規顧客を追加することができます。
列名を書かないINSERT文:
INSERT INT tablename VALUES (値1,値2,・・・値n)
Sub 新規顧客を追加する()
Dim StopNow As Boolean
Dim I As Integer
Dim strSQL As String
Dim strXLF As String
Dim strList As String
Dim strValues As String
Dim strInsert_0 As String
Dim strInsert_1 As String
strSQL = "SELECT * FROM [Sheet1$A1:G100]"
strXLF = "D:\大田区新規顧客リスト.xlsx"
strInsert_0 = "INSERT INTO [顧客名簿$A1:G100] VALUES XXXXX"
I = 0
Do
I = I + 1
strList = CircledText(strSQL, I, , strXLF, False)
strList = CutStr(strList, "VALUES", 2)
If Len(strList) > 0 Then
strInsert_1 = Replace(strInsert_0, "XXXXX", strList)
StopNow = SQLExecute(strInsert_1) <> True
End If
Loop Until Len(strList) = 0 Or StopNow
If StopNow Then
ErrorMsg "新規顧客を追加するマクロは中断しました。"
Else
Message "新規顧客を追加しました。"
End If
End Sub
Public Sub ErrorMsg(ByVal Msg As String)
MsgBox Msg, vbExclamation, " ｴﾗｰ発生のお知らせ"
End Sub
次は、上記マクロの実行結果です。
SQLExecute関数のソースコードSQLExecute
以下は、SQLExecute関数のソースコード全文です。DELETE文とDROP文を実行しないのであれば、冒頭の二つの関数のみをコピペしてSQLExecute関数から関連部分を削除してください。
Public Function SQLExecute(ByVal strSQL As String, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As Boolean
Dim isOK As Boolean
Dim strCommand As String
Dim strClearSQL As String
Dim strTableName As String
Application.Calculation = xlCalculationManual
isOK = True
strCommand = CutStr(UCase(strSQL), " ", 1)
Select Case strCommand
Case "UPDATE", "INSERT"
isOK = DoExecute(strSQL, xlFileName, isHeader)
Case "DELETE"
strClearSQL = Replace(UCase(strSQL), "DELETE", "SELECT *")
isOK = RowsClear(strClearSQL, xlFileName, isHeader)
Case "DROP"
strClearSQL = Replace(UCase(strSQL), "TABLE", "")
strClearSQL = Replace(strClearSQL, "DROP", "SELECT * FROM")
isOK = RowsClear(strClearSQL, xlFileName, isHeader)
If isOK Then
strTableName = CutStr(CutStr(strSQL, "[", 2), "]", 1)
isOK = DeleteHeader(strTableName)
End If
Case Else
Message "UPDATE文、INSERT文、DERETE文、DROP文以外は実行できません！"
End Select
Application.Calculation = xlCalculationAutomatic
SQLExecute = isOK
End Function
' ==============================
' 接続文字列のオプション IMEX
' ==============================
'
' 0‥‥エクスポートモード
' 1‥‥インポートモード
' 2‥‥リンクモード(省略=2)
'
Public Function DoExecute(ByVal strSQL As String, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As Boolean
On Error GoTo Err_DoExecute
Dim DataValue
Dim isOK As Boolean
Dim strHDR As String
Dim cnn As ADODB.Connection
Dim cmd As ADODB.Command
isOK = True
'
' SET文
'
Set cnn = New ADODB.Connection
Set cmd = New ADODB.Command
'
' 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=0;"
.Open xlFileName
.Errors.Clear
.BeginTrans
With cmd
.ActiveConnection = cnn
.CommandText = strSQL
.Execute
End With
.CommitTrans
End With
Exit_DoExecute:
On Error Resume Next
cnn.Close
Set cnn = Nothing
DoExecute = isOK
Exit Function
Err_DoExecute:
isOK = False
If cnn.Errors.Count > 0 Then
ErrMessage cnn.Errors(0), strSQL
cnn.RollbackTrans
Else
MsgBox "プログラムエラーが発生しました。" & _
"システム管理者に報告して下さい。(DoExecute)", _
vbExclamation, " 関数エラーメッセージ"
End If
Resume Exit_DoExecute
End Function
Public Function RowsClear(ByVal strSQL As String, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As Boolean
On Error GoTo Err_RowsClear
Dim isOK As Boolean
Dim strHDR As String
Dim cnn As Object 'ADOコネクションオブジェクト
Dim rst As Object 'ADOレコードセットオブジェクト
Dim fld As Object 'ADOフィールドオブジェクト
isOK = True
'
' ThisWorkbook.FullName の指定
'
If Len(xlFileName) = 0 Then
xlFileName = ThisWorkbook.FullName
End If
'
' Set文
'
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
'
' 接続
'
With cnn
strHDR = IIf(isHeader, "HDR=YES;", "HDR=NO;")
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = strHDR & "IMEX=1;"
.Properties("Extended Properties") = "Excel 12.0;"
cnn.Open xlFileName
With rst
.Open Source:=strSQL, _
ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText
If Not .BOF Then
.MoveFirst
Do
For Each fld In .Fields
If fld.Type <> 202 Then
fld.Value = Null
End If
Next fld
.Update
.MoveNext
Loop Until (.EOF)
End If
End With
End With
' -------------
' 終了処理
' -------------
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
'
' 空白行の削除
'
' SELECT * FROM [XXXXX$A1:Z100] WHERE ID=10
'
Dim isClose As Boolean
Dim intRowMax As Integer
Dim intColMax As Integer
Dim intRow_S As Integer
Dim intCol_S As Integer
Dim strBookName As String
Dim strTableName As String
Dim strSheetname As String
Dim strRange_S As String
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
strBookName = GetBookName(xlFileName)
strTableName = CutStr(CutStr(strSQL, "[", 2), "]", 1)
strSheetname = CutStr(strTableName, "$", 1)
strRange_S = CutStr(CutStr(strTableName, "$", 2), ":", 1)
intRow_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Row
intCol_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Column
'
' 削除後の行数の取得
'
intRowMax = DLookup("SELECT COUNT(*) FROM " & "[" & strTableName & "]", , xlFileName, isHeader)
If intRowMax > 0 And intColMax > 0 Then
'
' Set文
'
If Not BookIsOpened(strBookName) Then
isClose = True
Set objWorkbook = Workbooks.Open(xlFileName)
Set objWorksheet = objWorkbook.Worksheets(strSheetname)
Else
Set objWorksheet = Workbooks(strBookName).Worksheets(strSheetname)
End If
'
' 空白行を消す
'
objWorksheet.Range(Cells(intRow_S, intCol_S), _
Cells(intRow_S + intRowMax - 1, _
intCol_S + intColMax - 1)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
'
' 外部ブックを閉じる
'
If isClose Then
Application.DisplayAlerts = False 'メッセージを非表示に設定
Workbooks(strBookName).Close True
Application.DisplayAlerts = True 'メッセージを非表示に設定
End If
'
' 終了処理
'
Set objWorkbook = Nothing
Set objWorksheet = Nothing
End If
Exit_RowsClear:
On Error Resume Next
RowsClear = isOK
Exit Function
Err_RowsClear:
isOK = False
MsgBox "SELECT 文の実行時にエラーが発生しました。(RowsClear)" & Chr$(13) & Chr$(13) & _
"・Err.Description=" & Err.Description & Chr$(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
Resume Exit_RowsClear
End Function
Public Function GetBookName(ByVal strFullName As String) As String
Dim I As Integer
Dim N As Integer
Dim strDatas() As String
strDatas() = Split(strFullName, "\")
GetBookName = strDatas(UBound(strDatas()))
End Function
Public Function BookIsOpened(ByVal wbName As String) As Boolean
On Error Resume Next
BookIsOpened = Len(Workbooks(wbName).Name & "") > 0
End Function
Public Function DeleteHeader(ByVal strTableName As String, _
Optional ByVal xlFileName As String = "") As Boolean
On Error GoTo Err_DeleteHeader
Dim isOK As Boolean
Dim isClose As Boolean
Dim intRow_S As Integer
Dim intCol_S As Integer
Dim intCol_E As Integer
Dim strRange_S As String
Dim strBookName As String
Dim strSheetname As String
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
isOK = True
'
' ThisWorkbook.FullName の指定
'
If Len(xlFileName) = 0 Then
xlFileName = ThisWorkbook.FullName
End If
'
' 準備
'
' [XXXXX$A1:Z100]
'
'
strBookName = GetBookName(xlFileName)
strSheetname = CutStr(strTableName, "$", 1)
strRange_S = CutStr(CutStr(strTableName, "$", 2), ":", 1)
intRow_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Row
intCol_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Column
intCol_E = Range(CutStr(CutStr(strTableName, "$", 2), ":", 2)).Column
'
' Set文
'
If Not BookIsOpened(strBookName) Then
isClose = True
Set objWorkbook = Workbooks.Open(xlFileName)
Set objWorksheet = objWorkbook.Worksheets(strSheetname)
Else
Set objWorksheet = Workbooks(strBookName).Worksheets(strSheetname)
End If
'
' ヘッダー部を消す
'
' Range(Columns(2), Columns(3)).Clear
'
objWorksheet.Range(Cells(intRow_S, intCol_S), _
Cells(intRow_S, intCol_S + intCol_E - 1)).Clear
'
' 外部ブックを閉じる
'
If isClose Then
Application.DisplayAlerts = False 'メッセージを非表示に設定
Workbooks(strBookName).Close True
Application.DisplayAlerts = True 'メッセージを非表示に設定
End If
'
' 終了処理
'
Set objWorkbook = Nothing
Set objWorksheet = Nothing
Exit_DeleteHeader:
DeleteHeader = isOK
Exit Function
Err_DeleteHeader:
isOK = False
MsgBox "SELECT 文の実行時にエラーが発生しました。(RowsClear)" & Chr$(13) & Chr$(13) & _
"・Err.Description=" & Err.Description & Chr$(13) & _
vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
Resume Exit_DeleteHeader
End Function
これまで、一列だけ検索する DLookup関数、一行だけ検索するElookup関数のソースを公開してきましたが、次は、複数行を検索するDSelect関数を紹介します。
ExcelでSQLを使う-026: ソース公開-10 SQLExecute関数-2（Excel To Excel）
生後15日齢を迎えて仔犬たちが活発に動き回り始めました。
◇◇◇◇◇
９、エクセルでSQL文を実行するSQLExecute関数
９－２、SQLExecute関数で表の行を更新する
ADO でエクセルの表に接続して更新するには、エクセルの自動更新を停止する必要があります。相互参照をしていなければ、この限りではありません。
Public Function SQLExecute(ByVal strSQL As String, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As Boolean
Application.Calculation = xlCalculationManual
・・・・・
Application.Calculation = xlCalculationAutomatic
End Function
SQLExecute関数での自動更新の停止と再開が効を奏するのかはやってみなければわかりません。一番確かなのは、エクセルのオプションで停止することです。
次は、成績表の列＜実施日＞を更新するマクロと〔生徒名〕を変更するマクロです。実行結果は、次図の通りです。
Public Sub Message(ByVal Msg As String)
MsgBox Msg, vbInformation, " メッセージ"
End Sub
Sub Macro6()
Dim isOK As Boolean
Dim strSQL As String
strSQL = "UPDATE [生徒名簿$A1:C100] SET 名前='佐藤 彰' WHERE №=3;"
isOK=SQLExecute(strSQL)
If isOK Then
Message "＜生徒名簿＞の〔名前〕を更新しました。"
End IfEnd Sub
Sub Macro8()
Dim isOK As Boolean
Dim strSQL As String
strSQL = "UPDATE [成績表$D3:J100] SET 実施日='2018/12/20' WHERE 種類='期末試験'"
isOK = SQLExecute(strSQL)
If isOK Then
Message "＜成績表＞の〔実施日〕を更新しました。"
End If
End Sub
非常に短い記事となりましたが、本稿はここまでです。
次は、SQLExecute関数でINSERT文を実行してDドライブの『大田区新規顧客リスト』を＜顧客名簿＞に追加します。
ExcelでSQLを使う-025: ソース公開-09 SQLExecute関数-1（Excel To Excel）
99
生後13日前後から仔犬の目が明きました。
どうやら瞳の色はママ犬と同じ黒のようです。
◇◇◇◇◇
SQLExecute関数の紹介記事は、３つです。
１、SQLExecute関数で表を削除する。
２、SQLExecute関数で表を更新する。
３、SQLExecute関数で表に挿入する。
９、エクセルでSQL文を実行するSQLExecute関数
９－１、SQLExecute関数で表の行を削除する
ADO Connection の ExecuteメソッドとExcelの関係は、Excel固有の制約があって非常に微妙です。その制約の代表格が、Delete文の実行です。例えば、＜成績表＞から〔生徒_№〕が3の行を削除するSQL文を実行すると、次のようなエラーを得ます。
[イミディエイトウインドウ]
? DoExecute("DELETE FROM [成績表$D3:I100] WHERE 生徒_№=3")
False
そこで、削除対象の行データをNull値に変換して行詰めすることを試みても、DLookup関数を利用した参照を式に持つ行では実行時エラーが発生して変換できません。この問題を解決するには、削除対象の参照式をクリアする必要があります。現段階では、この仕組みは組み込んでいません。以上のような理由で、現段階では、参照式を持つ列が存在しない行だけがSQLExecute関数で削除することが可能です。
Sub Macro5()
Dim isOK As Boolean
Dim strSQL As String
strSQL = "DELETE FROM [顧客名簿$A1:G100] WHERE 郵便番号=1111236;"
isOK = SQLExecute(strSQL)
If isOK Then
Message "新宿区のお客様を＜顧客名簿＞から削除しました。"
End If
End Sub
SQLExecute関数のソースコードは、記事《３、SQLExecute関数で表に挿入する》で紹介します。ということで、本記事は、ここまでです。
ExcelでSQLを使う-024: ソース公開-08 getFieldInfo関数（Excel To Excel）
生後14日目。
仔犬たちの体重は1.3Kg～1.5Kgに。
大きなお腹を曝け出して臍天で寝ることも多くなりました。
◇◇◇◇◇
本稿で公開する getFieldInfo関数は、（それ自体が）エクセルで作表するのに何らかの貢献をするものではありません。DSelect関数が検索したデータを書き出すXlsWriter関数などを書く上で必要な情報を知る、あるいはDSelect関数で指定する＜列名＞を確認するのに役立つだけのものです。
８、表の情報を調べるgetFiledInfo関数
このような表をADOはどのように認識するのか？それを示しているのが次の図です。
《ヘッダーなし》を指定すると、ADOは＜F1＞＜F2＞・・・＜Fn＞という列名を生成することがわかります。
さて、次のような場合は？
このように認識します。
確かに、この程度の情報は、ネットで調べても知ることができます。でも、そこはやはり自分で確かめることも大事です。getFieldInfo関数は、その手助けをする関数です。
getFiledInfo関数
Public Function getFieldInfo(ByVal strSQL As String, _
Optional ByVal colDelimita As String = ";", _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True) As String
On Error GoTo Err_getFieldInfo
'
' 【要参照設定】
'
' Micrsoft ActiveX Data Objects 2.8 Library
'
Dim strHDR As String
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strList 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
If Not .BOF Then
.MoveFirst
strList = "Name（名前）: "
For Each fld In .Fields
With fld
strList = strList & .Name & colDelimita
End With
Next fld
strList = Replace(strList & "[END]", ";[END]", "") & Chr(13)
strList = strList & "Value（値）: "
For Each fld In .Fields
With fld
strList = strList & .Value & colDelimita
End With
Next fld
strList = Replace(strList & "[END]", ";[END]", "") & Chr(13)
strList = strList & "Type（型）: "
For Each fld In .Fields
With fld
strList = strList & .Type & colDelimita
End With
Next fld
strList = Replace(strList & "[END]", ";[END]", "") & Chr(13)
strList = strList & "Precision（精度）: "
For Each fld In .Fields
With fld
strList = strList & .Precision & colDelimita
End With
Next fld
Else
strList = ""
End If
End With
End With
getFieldInfo = IIf(Len(strList) > 0, Replace(strList & "[END]", ";[END]", ""), "")
Exit_GetFieldInfo:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Function
Err_getFieldInfo:
MsgBox "SELECT 文の実行時にエラーが発生しました。(getFieldInfo)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_GetFieldInfo
End Function
次は、エクセルの表にデータを追加、更新したり削除するSQLExecute関数を紹介します。
ExcelでSQLを使う-023: ソース公開-07 ELookup関数（Excel To Excel）
生後14日目。移行期を迎えて2日目。
産室を全体で2畳の広さに拡張。
仔犬たちは、産箱を出て動き回り始めました。
排泄場と産箱との間にある段差も越えて行き来しています。
◇◇◇◇◇
７、行データを検索・参照するELookup関数
ELookup関数は、次の次の次ぐらいに紹介するDSelect関数とDLookup関数の中間に位置するもので、一行全体のデータを”；”等の区切り子で連結して戻します。
例えば、DLookup関数は、英語最高得点者である林悟君の＜名前＞＜読み＞＜成績＞のデータを一度に取得することはできません。その難点をカバーしたのが ELookup関数です。
＜成績表＞と＜生徒名簿＞の二つの表から検索する
これまでは一つの表からだけ検索していましたが、SQLは複数の表から一度に検索することもできます。N5では、＜成績表＞と＜生徒名簿＞から検索しています。
SELECT
[生徒名簿$A1:C100].№, ←不要！
[生徒名簿$A1:C100].名前,
[生徒名簿$A1:C100].読み,
[成績表$D3:I100].成績
FROM [生徒名簿$A1:C100], [成績表$D3:I100]
WHERE
[成績表$D3:I100].生徒_№=[生徒名簿$A1:C100].№ AND
[成績表$D3:I100].種類='期末試験' AND
[成績表$D3:I100].科目_№=1
ORDER BY [成績表$D3:I100].成績 DESC
このレベルになるとエクセル初心者がエクセルの式を書いて複数の表から区切り子で連結して検索結果を取得するってのは相当に難しいと思われます。それを、いとも簡単に実現してくれるのがELookup関数です。
なお、ELookup関数は、予定にはなかったそれです。複数の表から・・・という課題をクリアする上で必要に迫られて昨日に書いたものです。次は、そのソースコードです。まあ、昨日に書いたと言っても、DLookup関数と違うのは朱記している3行程度です。
ELookup関数
Public Function ELookup(ByVal strSQL As String, _
Optional ByVal intSearch As Integer = 1, _
Optional ByVal xlFileName As String = "", _
Optional ByVal isHeader As Boolean = True, _
Optional ByVal returnValue As Variant = "") As Variant
On Error GoTo Err_ELookup
'
' 【要参照設定】
'
' 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 fld As ADODB.Field
Dim strHDR As String
Dim strList 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
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
For Each fld In .Fields
strList = strList & fld.Value & ";"
Next fld
Exit For
End If
.MoveNext
Next R
End If
End With
'
' 末尾の";"を消す
'
strList = Replace(strList & "[END]", ";[END]", "")
End With
Exit_ELookup:
On Error Resume Next
rst.Close
Set rst = Nothing
ELookup = IIf(Len(strList & "") > 0, strList, returnValue)
Exit Function
Err_ELookup:
If isEcho Then
MsgBox "SELECT 文の実行時にエラーが発生しました。(ELookup)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strSQL, _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_ELookup
End If
End Function
Public Function CutStr(ByVal Text As String, _
ByVal Separator As String, _
ByVal N As Integer) As String
Dim strDatas() As String
If N > 0 Then
strDatas = Split("" & Separator & Text, Separator, , 0)
CutStr = strDatas(N * Abs(N <= UBound(strDatas)))
End If
End Function
次は、エクセルの表情報を取得するGetFieldInfo関数を紹介します。表情報とは、ADOが表を読み込んだ場合の＜列名＞と＜データの型＞に関する情報を指します。これを知ることで、DSelect関数が検索したデータをエクセルのシートに書き出すことができます。
PS、エラー制御
DLookup関数、Elookup関数、DSelect関数を式に組み込んだ時は、広域変数 isEcho を真にしておくと、関連データを削除した際にエラーが表示されます。それが煩わしいので既定では、その値を偽にしていまっす。以下は、その真と偽とを切り替えるマクロです。
