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関数を紹介することにします。
