SQL ServerのデータをExcelに出力して罫線を引く
SQL ServerのテーブルのデータをAccess経由でExcelに出力して罫線を引きます。
テーブルを準備する
SQL Serverで「sample」という名前のデータベースの中に「Tサンプル」という名前のテーブルを用意しました。
SQL Serverにストアドプロシージャを準備する
SQL Serverに「exportサンプル」という名前のストアドプロシージャを用意しました。
これによりテンポラリテーブルにデータを書き込みますが、テンポラリテーブルに「通し番号」という名前の列を作成して日付ごとに通し番号を割り当てます。
この「通し番号」はExcelに出力したときに日付ごとにセルを塗りつぶす際に使用します。
CREATE PROCEDURE exportサンプル
@ID int OUTPUT
AS
BEGIN
SET NOCOUNT ON;
BEGIN TRY
DECLARE @table_name varchar(50);
DECLARE @sql varchar(1000);
SET @ID=@@SPID;
SET @table_name='';
SET @table_name=@table_name+'##TEMPサンプル'+CONVERT(varchar,@@spid);
SET @sql='';
SET @sql=@sql+'IF EXISTS(SELECT * FROM tempdb.sys.tables WHERE name='''+@table_name+''')';
SET @sql=@sql+'DROP TABLE '+@table_name+';';
SET @sql=@sql+'CREATE TABLE '+@table_name;
SET @sql=@sql+'(';
SET @sql=@sql+'明細番号 bigint';
SET @sql=@sql+',日付 date';
SET @sql=@sql+',商品コード varchar(10)';
SET @sql=@sql+',商品名 varchar(20)';
SET @sql=@sql+',数量 int';
SET @sql=@sql+',通し番号 bigint';
SET @sql=@sql+');';
SET @sql=@sql+'INSERT INTO '+@table_name;
SET @sql=@sql+' SELECT 明細番号,日付,商品コード,商品名,数量,';
SET @sql=@sql+'DENSE_RANK() OVER(ORDER BY 日付) AS 通し番号';
SET @sql=@sql+' FROM Tサンプル ORDER BY 日付;';
EXECUTE(@sql);
RETURN -1
END TRY
BEGIN CATCH
RETURN 0
END CATCH
END
SQL ServerのテンポラリテーブルのデータをExcelに出力して罫線を引くコードの記述
Accessの標準モジュールに以下のコードを記述しました。
「日付」,「商品コード」,「商品名」は1行上の値と同じ時はフォント色を背景色と同じにして空欄に見えるようにしました。
罫線、背景色、フォント色の設定には条件付き書式を使いました。
Public Sub sample()
Dim strCN_sample As String
strCN_sample = "DRIVER={ODBC Driver 17 for SQL Server};SERVER=LAPTOP-114315\SQLEXPRESS;DATABASE=sample;UID=admin;PWD=1111"
Dim cn As New ADODB.Connection
cn.CursorLocation = adUseServer
cn.Open strCN_sample
Dim sid As Integer 'SQL Serverが割り当てるセッションIDを格納する変数
Dim cmd As New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "exportサンプル"
cmd.CommandTimeout = 3
cmd.Parameters.Append cmd.CreateParameter("@return_value", adInteger, adParamReturnValue, , Null)
cmd.Parameters.Append cmd.CreateParameter("@ID", adInteger, adParamOutput, , Null)
cmd.execute
If CBool(cmd.Parameters("@return_value").Value) = False Then GoTo Errh
sid = cmd.Parameters("@ID").Value
Dim rs As New ADODB.Recordset
rs.Open "SELECT * FROM [##TEMPサンプル" & CStr(sid) & "]", cn, adOpenKeyset, adLockOptimistic
Dim xlApp As Object
Dim wb As Object
Dim ws As Object
Dim file_name As String
Dim i As Integer
file_name = CurrentProject.Path & "\sample.xlsx"
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Add
Set ws = wb.Worksheets(1)
rs.MoveLast
Dim startRow As Integer
startRow = 2
Dim lastRow As Long
lastRow = rs.RecordCount + 1
Dim lastColumn As Integer
lastColumn = 5
For i = 0 To 4
ws.Cells(1, i + 1) = rs.Fields(i).Name
Next
rs.MoveFirst
ws.Range("A2").CopyFromRecordset rs
With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 1))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[0]C2<>R[-1]C2"
.FormatConditions(1).Borders(xlTop).LineStyle = xlContinuous
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[0]C2=R[-1]C2"
.FormatConditions(2).Borders(xlTop).LineStyle = xlDot
.FormatConditions(2).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(R[0]C6,2)=1"
.FormatConditions(3).Interior.Color = vbYellow
.FormatConditions(3).StopIfTrue = False
End With
With ws.Range(ws.Cells(startRow, 2), ws.Cells(lastRow, 2))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[-1]C[0]<>R[0]C[0]"
.FormatConditions(1).Borders(xlTop).LineStyle = xlContinuous
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(R[0]C6,2)=1"
.FormatConditions(2).Interior.Color = vbYellow
.FormatConditions(2).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(R[-1]C[0]=R[0]C[0],MOD(R[0]C6,2)=0)"
.FormatConditions(3).Font.Color = vbWhite
.FormatConditions(3).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(R[-1]C[0]=R[0]C[0],MOD(R[0]C6,2)=1)"
.FormatConditions(4).Font.Color = vbYellow
.FormatConditions(4).StopIfTrue = False
End With
With ws.Range(ws.Cells(startRow, 3), ws.Cells(lastRow, 4))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[-1]C2<>R[0]C2"
.FormatConditions(1).Borders(xlTop).LineStyle = xlContinuous
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(R[-1]C[0]<>R[0]C[0],R[-1]C2=RC2)"
.FormatConditions(2).Borders(xlTop).LineStyle = xlDot
.FormatConditions(2).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(R[0]C6,2)=1"
.FormatConditions(3).Interior.Color = vbYellow
.FormatConditions(3).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(R[-1]C[0]=R[0]C[0],MOD(R[0]C6,2)=0)"
.FormatConditions(4).Font.Color = RGB(255, 255, 255)
.FormatConditions(4).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(R[-1]C[0]=R[0]C[0],MOD(R[0]C6,2)=1)"
.FormatConditions(5).Font.Color = vbYellow
.FormatConditions(5).StopIfTrue = False
End With
With ws.Range(ws.Cells(startRow, 5), ws.Cells(lastRow, 5))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[0]C2<>R[-1]C2"
.FormatConditions(1).Borders(xlTop).LineStyle = xlContinuous
.FormatConditions(1).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=R[0]C2=R[-1]C2"
.FormatConditions(2).Borders(xlTop).LineStyle = xlDot
.FormatConditions(2).StopIfTrue = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(R[0]C6,2)=1"
.FormatConditions(3).Interior.Color = vbYellow
.FormatConditions(3).StopIfTrue = False
End With
ws.Columns("A:E").AutoFit
ws.Columns("F:F").EntireColumn.Hidden = True
ws.Range("A:A").TextToColumns Destination:=ws.Range("A:A")
ws.Range("C:C").TextToColumns Destination:=ws.Range("C:C")
xlApp.DisplayAlerts = False
wb.SaveAs file_name
xlApp.DisplayAlerts = True
xlApp.Quit
Set xlApp = Nothing
rs.Close: Set rs = Nothing
Set cmd = Nothing
cn.Close: Set cn = Nothing
Exit Sub
Errh:
MsgBox "エラーが発生しました。", vbExclamation, "確認"
Set cmd = Nothing
cn.Close: Set cn = Nothing
End Sub
