OPはVBAの初心者向けの理解を表明しているため、このコードを使用する可能性のある他の人は、コードを読んでコード内のコメントに注意してください。
この VBA を可能な解決策と考えてください。アクセス 2007 データベースでこれをテストしました。on_click イベントがこのサブルーチンを呼び出すボタンを含むフォームを作成しました。
これが実行されると、ボタンの on_click イベントで、「tbl_output」に含まれるデータを Excel スプレッドシートにエクスポートする VBA モジュールを呼び出すことができます。
以下は、要求どおりに機能している証拠を示すスクリーンショットです。
これを可能にするために私が思いついたコードは次のとおりです。これは、最終結果を達成する方法についての私の解釈です。
Option Explicit
Public Sub QueryRollUp()
Dim db As Database
Dim rst_Input As DAO.Recordset
Dim rst_Output As DAO.Recordset
Dim strSQL As String
Dim tdfNew As TableDef
Dim tdfLoop As TableDef
Dim prpLoop As Property
Dim s_tdef As String
Dim s_CurrentRollUp As String
Dim s_CurrentField1 As String
Dim s_CurrentDate As String
Dim s_CurrentQty1 As Integer
Dim s_CurrentQty2 As Integer
Dim s_CurrentQty3 As Integer
Dim s_CurrentQty4 As Integer
Dim i As Integer
' If the subroutine is going to access parts of the database (tables, queries, etc.)
' you must have a representation of the database in the code.
' In this code, I use 'db' as that representation.
' VBA has a shortcut for defining the database that is currently open, and that is 'CurrentDB'.
' You can define an external database if necessary, but that goes beyond the scope of this example.
' The below line sets the database code object 'db' equal to this database
Set db = CurrentDb
' The next step is to create a new table programaitcally for the output to go
' I choose to do this in code instead of building it in table designer
' because I want to ensure you get the correct tbl_Output that my code is
' expecting. If you were desining a new module, and new how the correct table needed
' to be designed, you can omit everything between the hash marks
'#####################################################################################
' This current database.
' I like to use 'With' so I don't have to keep typing the name.
' I can just type .something and the code knows I really mean db.something
' Each 'With' must have an 'End With' to let the code know when you are no longer
' wanting it to assume you are using the short cut.
With db
'this loops trough all of the items in the table definitions
'the looping logic takes place between the % signs
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
For Each tdfLoop In .TableDefs
' Check the name of an item 'tdfLoop.Name' to see if it the
' same as "tbl_Output".
If tdfLoop.Name = "tbl_Output" Then
' We are going to create this table later.
' If the table already exists, it will cause an error and
' the code will halt. Deleting the table prevents the
' conflict.
db.TableDefs.Delete "tbl_Output"
End If
' This bit of code moves to the next item in the table definitions collection
' and then loops back and tests for tbl_Output again.
Next tdfLoop
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
End With
' Create a new TableDef object.
' This assigns the object "tbl_Output" to a variable so I can access it
' shorthand. The variable is called 'tdfNew'
Set tdfNew = db.CreateTableDef("tbl_Output")
' Using the 'With' again, but this time is tdfNew, and not db that
' I am shortcutting. Remember that there is an implied 'tdfNew'
' in front of each .Fields.Append an also .CreateField(...)
With tdfNew
' Create fields and append them to the new TableDef
' object. This must be done before appending the
' TableDef object to the TableDefs collection of the
' database.
' Each line here adds a new field to the table
' This is the code equivilent of designing a table
' in the graphical UI
.Fields.Append .CreateField("name", dbText)
.Fields.Append .CreateField("column_date", dbText)
.Fields.Append .CreateField("qty1", dbInteger)
.Fields.Append .CreateField("qty2", dbInteger)
.Fields.Append .CreateField("qty3", dbInteger)
.Fields.Append .CreateField("qty4", dbInteger)
' Append the new TableDef object to the database.
' The net effect of this is to create a new table
' within the database using the information above.
db.TableDefs.Append tdfNew
End With
'#####################################################################################
' Open rst_Output as a recordset tied to new 'tbl_Output' table\
' the .OpenRecordset creates an incode representation of a database table.
' All of the specified table columns are recreated, and populated. If no
' specific columns are listed (such as in a query), then it defaults to all columns.
' When using the .OpenRecordset("table_name", [type]) method, there are several [types]
' you can choose. The type you choose determines the way it opens in the code
' and what you can do with it. The most flexible is dbOpenDynaset, but is generally slower
' in performacne with huge amounts of data. dbOpenTable is equivelant to opening the table directly
Set rst_Output = db.OpenRecordset("tbl_Output", dbOpenTable)
' Create query string to pull data from the database.
' For readability I have split this process up on several lines.
' Each time a new line is needed you must add the
' new information to the information you already have
' This is accomplished by doing strSQL = strSQL & "..." on each line after the first
' If you just did strSQL = "..." for each line, you would overwrite what was there before
strSQL = "select field1, column_date, sum(qty1) as Total1, sum(qty2) as Total2, sum(qty3) as Total3, sum(qty4) as Total4 "
strSQL = strSQL & " from [table]"
strSQL = strSQL & " group by field1, column_date"
strSQL = strSQL & " union all"
strSQL = strSQL & " select field1, 'subtotal' as column_date, sum(qty1) as Total1, sum(qty2) as Total2, sum(qty3) as Total3, sum(qty4) as Total4 "
strSQL = strSQL & " from [table]"
strSQL = strSQL & " group by field1"
strSQL = strSQL & " union all"
strSQL = strSQL & " select '', 'Grand Total' as column_date, sum(qty1) as Total1, sum(qty2) as Total2, sum(qty3) as Total3, sum(qty4) as Total4 "
strSQL = strSQL & " from [table]"
strSQL = strSQL & " order by field1 desc, column_date asc"
' After the above code, your whole query is now stored in strSQL.
' Execute query and populate rst_Input with the result set.
' Ensure full recordset has been retrieved before continuing.
' This becomes more important the larger the result set is.
' The dbOpenSnapshot type is like creating a virtual image
' of the data just queried. Like a photo, it can't be changed,
' only looked at. Since we only want to read the data, this
' is a more optimal type of OpenRecordset than a dynaset.
' All of the contents are moved into rst_Input.
Set rst_Input = db.OpenRecordset(strSQL, dbOpenSnapshot)
' Now we are going to manipulate the information
' returned by the query as it is stored inside the
' rst_Input variable.
With rst_Input
' The .MoveLast forces the recordset to go the very last
' record of the returned query. Omitting this step could
' result in the code starting before all of the data is
' returned by the query.
' .MoveFirst returns to the top of the list once all data
' is returned
.MoveLast
.MoveFirst
' Begin process of evaluating query results
' This will keep looping until the current record is the
' end of the returned data.
Do Until .EOF
' Use 'i' as the index of the current roll-up value.
' Default this value to 1 for the first each time the field1 value changes.
' The example has 'xyz' and 'abc'.
i = 1
' Move the data from the query which is stored in
' the rst_Input from the fields to variables
s_CurrentRollUp = .Fields("field1").Value
s_CurrentField1 = .Fields("field1").Value
s_CurrentDate = .Fields("column_date").Value
s_CurrentQty1 = .Fields("total1").Value
s_CurrentQty2 = .Fields("total2").Value
s_CurrentQty3 = .Fields("total3").Value
s_CurrentQty4 = .Fields("total4").Value
' While working with all field1 values (i.e. 'xyz') values which are the same
' the following 'Do While' loop will execute.
Do While s_CurrentRollUp = s_CurrentField1
' If this is the firs time the values match do everything betwen the '#' marks
If i = 1 Then
'#############################################
' If the CurrentDate value is not a real date
' do the following
If s_CurrentDate = "Grand Total" Then
With rst_Output
' .AddNew tells the recordset we are adding a new record
.AddNew
' Here we use a '!' (pronounced 'bang') to let VBA know
' we are accessing members of a collection, and not a
' method of doing something with rst_Output.
!column_date = s_CurrentDate
!qty1 = s_CurrentQty1
!qty2 = s_CurrentQty2
!qty3 = s_CurrentQty3
!qty4 = s_CurrentQty4
' .Update tells the recordset we are done adding, and to save it
.Update
End With
' If the CurrentDate value is a real date
' do the following
Else
With rst_Output
.AddNew
!Name = s_CurrentField1
!column_date = s_CurrentDate
!qty1 = s_CurrentQty1
!qty2 = s_CurrentQty2
!qty3 = s_CurrentQty3
!qty4 = s_CurrentQty4
.Update
End With
End If
' set index to optimistically reflect second record of rollup
' Values above '1' tell the logic that we are still using the
' same field1 ('xyz') value, but are no longer on the first
' occurance of the 'xyz' value.
i = i + 1
' move to the next record of the input recordset
.MoveNext
'test if last move is the end of file
If .EOF Then
'exit sub if the end of file has been reached.
Exit Sub
End If
' get next field1 value to test in the do while exit condition
If IsNull(.Fields("field1").Value) Then
s_CurrentField1 = " "
Else
s_CurrentField1 = .Fields("field1").Value
End If
'#############################################
' If there is another record with the same field1 value (i.e. 'xyz'
' then do the following logic.
' This will replace the 'xyz' with an empty value so it does not
' show up in the tbl_Output table
ElseIf i > 1 Then
' Move the data from the query which is stored in
' the rst_Input from the fields to variables
s_CurrentField1 = " "
s_CurrentDate = .Fields("column_date").Value
s_CurrentQty1 = .Fields("total1").Value
s_CurrentQty2 = .Fields("total2").Value
s_CurrentQty3 = .Fields("total3").Value
s_CurrentQty4 = .Fields("total4").Value
With rst_Output
.AddNew
!Name = s_CurrentField1
!column_date = s_CurrentDate
!qty1 = s_CurrentQty1
!qty2 = s_CurrentQty2
!qty3 = s_CurrentQty3
!qty4 = s_CurrentQty4
.Update
End With
' Set index to optimistically reflect second record of rollup
i = i + 1
' Move to the next record of the input recordset
.MoveNext
' Get next field1 value to test in the do while exit condition
' The IsNull makes sure that in the event that no information
' exists in the field1 column of the table, it is replaced with
' a " " character to avoid an invalid use of NULL in the variable
If IsNull(.Fields("field1").Value) Then
s_CurrentField1 = " "
Else
s_CurrentField1 = .Fields("field1").Value
End If
End If
Loop 'do while
Loop 'do until
End With
' Now that everything has finished, it's proper coding technique
' to release all of the resources consumed by our data containing
' variables.
db.Close
rst_Output.Close
rst_Input.Close
Set db = Nothing
Set rst_Output = Nothing
Set rst_Input = Nothing
End Sub