|
▼さつき さん:
こんにちは。
何とかして集計に合計を加えたSQLを一括でできないか色々悩んでいたのですが、
こんな感じでいかがでしょうか?
Sub 集計3()
Dim SQLCode As String
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim dbName As String
Dim Kiten As Range
Dim Cnt As Long
Dim Num As Long
Dim Ten As String
Dim Kei As String
Dim Syu As String
Dim Tan As String
'DBの設定
dbName = "C:週報.mdb"
'起点の設定
Set Kiten = Range("B2")
'集計クエリのSQL文を作成
SQLCode = "SELECT Q.* " _
& "FROM [ " _
& "TRANSFORM Count(累計.品名) AS 品名のカウント " _
& "SELECT 累計.店名, 累計.契約者名, 累計.担当者名 " _
& "FROM 累計 " _
& "GROUP BY 累計.店名, 累計.契約者名, 累計.担当者名 " _
& "PIVOT 累計.週 " _
& "IN ('S1','S2','S3','S4','S5') " _
& "]. AS Q " _
& "UNION ALL SELECT T.* " _
& "FROM [ " _
& "TRANSFORM Count(累計.品名) AS 品名のカウント " _
& "SELECT 累計.店名, '' AS 契約者名, '合計' AS 担当者名 " _
& "FROM 累計 " _
& "GROUP BY 累計.店名, '', '合計' " _
& "PIVOT 累計.週 " _
& "IN ('S1','S2','S3','S4','S5') " _
& "]. AS T " _
& "ORDER BY 店名 ,契約者名 DESC;"
'ADOでSQLを実行
cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & dbName
cnn.Open
'下行のコメントを外すとイミディエトウィンドウにSQLを表示
'Debug.Print SQLCode
rst.Open SQLCode, cnn
'フィールド名を起点の列に挿入
For Cnt = 0 To rst.Fields.Count - 1
Kiten.Offset(0, Cnt).Value = rst(Cnt).Name
Next
Kiten.Offset(0, rst.Fields.Count).Value = "品名"
'データの貼り付け
Kiten.Offset(1, 0).CopyFromRecordset rst
rst.Close
'店名のフィールドが空になるまで
For Cnt = Kiten.Row + 1 To Kiten.End(xlDown).Row
'「合計」の行はスキップ
If Cells(Cnt, Kiten.Column + 2) <> "合計" Then
'「S1」〜「S5」までをループ
For Num = Kiten.Column + 3 To Kiten.Column + 7
'値が入っているフィールドが見つかったら変数「Syu」にフィールド名を入力
If Not (IsEmpty(Cells(Cnt, Num).Value)) Then
Syu = Cells(Kiten.Row, Num).Value: Exit For
End If
Next
SQLCode = "SELECT 累計.品名 " _
& "FROM 累計 " _
& "WHERE 店名 = '" & Cells(Cnt, Kiten.Column).Value & "' AND " _
& "契約者名 = '" & Cells(Cnt, Kiten.Column + 1).Value & "' AND " _
& "担当者名 = '" & Cells(Cnt, Kiten.Column + 2) & "' AND " _
& "週 = '" & Syu & "'"
'下行のコメントを外すとイミディエトウィンドウにSQLを表示
'Debug.Print SQLCode
rst.Open SQLCode, cnn
'品名がある限りループして「品名」フィールドに追加
Do Until rst.EOF
Cells(Cnt, Kiten.Column + 8) = Cells(Cnt, Kiten.Column + 8) & " " & rst![品名]
rst.MoveNext
Loop
rst.Close
End If
Next
'オブジェクトの解放
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Kiten.Offset(0, 8).Columns.EntireColumn.AutoFit
Set Kiten = Nothing
End Sub
累計テーブルの「週」フィールドが文字型の「S1」,「S2」というような値であれば
うまくいくと思います。
|
|