I am using a userform in excel to allow users to import claims data from an Access database and paste it into a destination in the workbook.
The code below allows the user to import claim numbers for each of the last 5 years for a particular policy number.
The access database currently summarizes claims data so that all the claims for policy Y in year Y are on one row. However, I need to change the code so that the individual claim amounts can be pulled in and then adjusted based on parameters set out in the userform (i.e. capping claims at 100,000) and then summarized so that all the (adjusted claims) are on a single row for each year.
I have included an image of what the database structure looked like before and what it looks like now. I would like to include something that loops over all the claims in an underwriting year and sums up the total.
database
Without getting into too much detail, I would like know how to summarize the data after I have adjusted them. Do I need another loop in the code below?
Public Const RawdataDB = "N:\***\Rawdata DB.accdb"
Private Sub CommandButton1_Click()
Dim dbRawData As Database
Dim rTemp As Recordset
Dim sSQL As String
Dim YearTemp As Integer
Dim i As Integer
i = 1
Do Until i = 6
YearTemp = Year(Range("RenewalDate")) - i
Set dbRawData = OpenDatabase(RawdataDB, False, False, "MS Access;PWD=*****")
sSQL = "SELECT Galway_Claims.* FROM Galway_Claims WHERE (Galway_Claims.PolicyNo=" & Range("PolicyNoNew") & " AND Galway_Claims.Year=" & Range("UWYear") - 1 & " AND Galway_Claims.HistoricYear=" & i & ");"
Set rTemp = dbRawData.OpenRecordset(sSQL)
Controls("ClaimNos" & i).Value = Format(rTemp!ClaimNosD, "0.0")
i = i + 1
Loop
rTemp.Close
End Sub
The easiest here seems to sum everything in access: Make another query:
sSQL = "SELECT Sum(Galway_Claims.ClaimAmts) as theSum FROM Galway_Claims WHERE (Galway_Claims.PolicyNo=" & Range("PolicyNoNew") & " AND Galway_Claims.Year=" & Range("UWYear") - 1 & " AND Galway_Claims.HistoricYear=" & i & ");"
And then read this in like before:
sSQL = "SELECT Galway_Claims.* FROM Galway_Claims WHERE (Galway_Claims.PolicyNo=" & Range("PolicyNoNew") & " AND Galway_Claims.Year=" & Range("UWYear") - 1 & " AND Galway_Claims.HistoricYear=" & i & ");"
Set rTemp = dbRawData.OpenRecordset(sSQL)
Controls("ClaimNos" & i).Value = Format(rTemp!ClaimNosD, "0.0")
sSQL = "SELECT Sum(Galway_Claims.ClaimAmts) as theSum FROM Galway_Claims WHERE (Galway_Claims.PolicyNo=" & Range("PolicyNoNew") & " AND Galway_Claims.Year=" & Range("UWYear") - 1 & " AND Galway_Claims.HistoricYear=" & i & ");"
Set rTempSum = dbRawData.OpenRecordset(sSQL)
Controls("ClaimNos" & i).Value = Format(rTempSum!theSum, "0.0")
...
Related
Original code link: MS Access - Convert rows values into columns values
I have a follow up to a question where the answer didn't completely resolve, but got super close. It was asked at the original code link above. It's the single page on the net that actually addresses the issue of transposing multiple values in a one-to-many relationship set of columns to a single row for each related value in a dynamic manner specifically using VBA. Variations of this question have been asked about a dozen times on this site and literally none of the answers goes as far as Vlado did (the user that answered), which is what's necessary to resolve this problem.
I took what Vlado posted in that link, adjusted it for my needs, did some basic cleanup, worked through all the trouble-shooting and syntax problems (even removed a variable declared that wasn't used: f As Variant), and found that it works almost all the way. It generates the table with values for the first two columns correctly, iterates the correct number of variable count columns with headers correctly, but fails to populate the values within the cells for each of the related "many-values". So close!
In order to get it to that point, I have to comment-out db.Execute updateSql portion of the Transpose Function; 3rd to last row from the end. If I don't comment that out, it still generates the table, but it throws a Run-Time Error 3144 (Syntax error in UPDATE statement) and only creates the first row and all the correct columns with correct headers (but still no valid values inside the cells). Below is Vlado's code from the link above, but adjusted for my field name needs, and to set variables at the beginning of each of the two Functions defined. The second Function definitely works correctly.
Public Function Transpose()
Dim DestinationCount As Integer, i As Integer
Dim sql As String, insSql As String, fieldsSql As String, updateSql As String, updateSql2 As String
Dim db As DAO.Database, rs As DAO.Recordset, grp As DAO.Recordset
Dim tempTable As String, myTable As String
Dim Var1 As String, Var2 As String, Var3 As String, Var4 As String
tempTable = "Transposed" 'Value for Table to be created with results
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
Var4 = "Dest" 'Value for Column Name Prefixes
DestinationCount = GetMaxDestination
Set db = CurrentDb()
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tempTable & "'")) Then
DoCmd.DeleteObject acTable, tempTable
End If
fieldsSql = ""
sql = "CREATE TABLE " & tempTable & " (" & Var1 & " CHAR," & Var2 & " CHAR "
For i = 1 To DestinationCount
fieldsSql = fieldsSql & ", " & Var4 & "" & i & " INTEGER"
Next i
sql = sql & fieldsSql & ")"
db.Execute (sql)
insSql = "INSERT INTO " & tempTable & " (" & Var1 & ", " & Var2 & ") VALUES ("
Set grp = db.OpenRecordset("SELECT DISTINCT " & Var1 & ", " & Var2 & " FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & "")
grp.MoveFirst
Do While Not grp.EOF
sql = "'" & grp(0) & "','" & grp(1) & "')"
db.Execute insSql & sql
Set rs = db.OpenRecordset("SELECT * FROM " & myTable & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'")
updateSql = "UPDATE " & tempTable & " SET "
updateSql2 = ""
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
updateSql2 = updateSql2 & "" & Var3 & "" & i & " = " & rs(2) & ", " ' <------- MADE CHANGE FROM (3) to (2)
rs.MoveNext
Loop
updateSql = updateSql & Left(updateSql2, Len(updateSql2) - 1) & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'"
db.Execute updateSql ' <-- This is the point of failure
grp.MoveNext
Loop
End Function
Public Function GetMaxDestination()
Dim rst As DAO.Recordset, strSQL As String
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
strSQL = "SELECT MAX(CountOfDestination) FROM (SELECT Count(" & Var3 & ") AS CountOfDestination FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & ")"
Set rst = CurrentDb.OpenRecordset(strSQL)
GetMaxDestination = rst(0)
rst.Close
Set rst = Nothing
End Function
Sample Table:
Sample Data:
Add a Debug.Print updateSql before that Execute line and will see improper syntax in SQL statement. Need to trim trailing comma from updateSql2 string. Code is appending a comma and space but only trims 1 character. Either eliminate space from the concatenation or trim 2 characters.
Left(updateSql2, Len(updateSql2) - 2)
Concatenation for updateSql2 is using Var3 instead of Var4.
Source field is a number type in ConvergeCombined and this triggers a 'type mismatch' error in SELECT statement to open recordset because of apostrophe delimiters Var1 & " = '" & grp(0) & "' - remove them from two SQL statements.
Also, Source value is saved to a text field in Transposed, make it INTEGER instead of CHAR in the CREATE TABLE action.
So with the help of a friend I figured it out. It turns out I needed two Functions because the one-to-many relationships go both directions in my case. I explain below what needs to happen in comments for this to work. Essentially I went with the second comment under the question I posed (pre-defining field names in static tables because there is a limited number of fields that any person will need - it can't exceed 256 fields anyway, but it isn't always practical to use more than a dozen or so fields - this way allows for both and at the same time to simplify the code significantly).
This solution actually works - but it's dependent on having tables (or queries in my situation) labeled ConvergeSend and ConvergeReceive. Also, it's important to note that the instances where the Destination is single and the Source is plural, the table or query (ConvergeSend/ConvergeReceive) must have the Destination value as a column TO THE LEFT of the iterated Source columns. This is also true (but reverse naming convention) for the other table/query (the Source column must be TO THE LEFT of the iterated Destination columns).
' For this code to work, create a table named "TransposedSend" with 8 columns: Source, Destination1, Destination2,...Destination7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeSend()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedSend", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedSend (Source) SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Source, Destination, [Destination App Name] FROM ConvergeSend WHERE Source = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedSend SET Destination" & i & " = '" & rs(1) & "', [Destination" & i & " App Name] = '" & rs(2) & "'" & " WHERE Source = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
' For this code to work, create a table named "TransposedReceive" with 8 columns: Destination, Source1, Source2,...Source7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeReceive()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedReceive", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedReceive (Destination) SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Destination, Source, [Source App Name] FROM ConvergeReceive WHERE Destination = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedReceive SET Source" & i & " = '" & rs(1) & "', [Source" & i & " App Name] = '" & rs(2) & "'" & " WHERE Destination = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
For starters, I only started yesterday with the attempts of introducing SQL into my VBA code.
I'm trying to use VBA/SQL to Insert Data into a local table, made from a combination of a Database table and form input. I want to know how to trigger a "0 Lines retrieved".
I've already tried looking on several pages on how to handle "0 lines to Insert" when running a DoCmd.RunSQL("INSERT INTO ... SELECT ... FROM ... WHERE ...).
The code itself works when there is data present, so that's not the problem.
The problem itself is when I don't find data, I want to trigger a messagebox that gives instructions on how to handle the current situation.
Sadly, I have not found on how I can trigger this.
sqlTempInsert = "INSERT INTO tblScanInput (Support, EAN, Counted, Product, Description, Launched, Collected) " & _
"SELECT " & lblSupportData.Caption & ", " & txtEANInput.Value & ", "
If txtAmountInput.Visible = True Then
sqlTempInsert = sqlTempInsert & txtAmountInput.Value & ", "
ElseIf txtAmountInput.Visible = False Then
sqlTempInsert = sqlTempInsert & "1, "
End If
sqlTempInsert = sqlTempInsert & "GEPRO.CODPRO, GEPRO.DS1PRO, GESUPDC.UVCSRV, GESUPDC.UVCLIV " & _
"FROM [Database_Table] GESUPDC LEFT OUTER JOIN [Database_Table] GEPRO ON GESUPDC.CODPRO = GEPRO.CODPRO " & _
"WHERE GESUPDC.NUMSUP = " & lblSupportData.Caption & " AND GESUPDC.EDIPRO = '" & txtEANInput.Value & "';"
DoCmd.RunSQL(sqlTempInsert)
Use .Execute and .RecordsAffected.
Dim db As DAO.Database
Dim x As Long
Set db = CurrentDb
db.Execute sqlTempInsert, dbFailOnError
x = db.RecordsAffected
If x = 0 Then
' nothing was inserted
End If
Note: pay attention to Delete 5 Records but RecordsAffected Property is 0
I am pulling another workbook containing a table that has Columns like ItemCreationDate, and most columns (total 28 such columns) that begin with the word "Global" in them. i want to
pull these "Global" columns (including ItemCreationDate) into an SQL recordset,
add a new Column called Old/New and then
UNPIVOT them i.e. Stack them up one above the other and
in the next column, list their Column items along with their Counts.
Their Counts are derived based on the ItemCreationDate where any date <2015 is OLD & >=2015 is NEW
Final Output should be as shown in Output sheet.
i have attached a Sample.xlsx file where i have shown how i have to arrive at the Output tab starting from the Data sheet. This Data sheet is actually the input that i want to pull into a recordset and spit out the table as shown in the Output sheet. I don't want to create Pivot table as its cumbersome and the data is quite a lot, and i want an alternative SQL approach, wherein i can quickly aggregate the data and insert it into sheet in one go.
i am not using SQL Server, so cannot use the UNPIVOT command or Dynamic SQL to loop thru all the "Global" columns.
Basically i want to form a correct SQL string something like....
Dim arrSQL as variant
......
......
RS.Filter="Like Global*"
......
arrSQL = JOIN(RS.Fields, vbCr)
strSQL = "SELECT [arrSQL], IIF(YEAR([ITEM CREATION DATE])>=YEAR(DATE())-1,""NEW"",""OLD"") AS [New/Old] from [Data$] GROUP BY...."
strSQL = strSQL & " UNION ALL " & vbcr & _
strSQL = strSQL & " ......
Now, run SQL on same recordset to reduce the columns and get required data format....
i know the above is not quite correct, but something on those lines so that i can get the correct output as show in the Output tab.
can anyone help quickly?
Edits for #a_horse_with_no_name :
see the screenshots of the sample file:
Data sheet:
this is actually a table from an input workbook that i want to pull in a Recordset. See the various "Global" column headings and their items that i want to unpivot.
This are the 2 intermediate sheets "New" & "Old" i have to create everytime (that i want to get rid of actually). any items found in 2015 or later are put in New, whereas rest are put in Old.
JFYI, the formulae that are manually used in Output columns are :
C column (New):
=COUNTIF(INDEX(New!$A:$D,0,MATCH($A2,New!$1:$1,0)),Output!$B2)
D Column (Old):
=COUNTIF(INDEX(Old!$A:$D,0,MATCH($A2,Old!$1:$1,0)),Output!$B2)
E Column (% New):
=Output!C2/SUM(C$2:C$6)
F Column (% Old):
=Output!D2/SUM(D$2:D$6)
G Column (Index):
=IF(AND(E2<=0,F2<=0),0,IF(AND(E2>0,F2>0),E2/F2,1))
Hope this helps.
Indeed, you can run SQL queries in MS Excel using the Jet/ACE SQL Engine (a Windows .dll file) which is the very data store that MS Access is connected to by default. And as such, this technology equipped on all PCs is not restricted to any one Office/Windows program.
Consider the following Excel VBA macro (if using Excel on PC) that connects to ACE via ADO running a union of three aggregate SQL queries (GLOBAL VIT/CALC, GLOBAL FLAVOURS, GLOBAL FLAVOUR GROUP) and conditional New and Old counts/percentages. The latter percentage column pair required subqueries.
For proper setup, do the following:
Make sure Item Creation Date is in MM-DD-YYYY (US-based) or DD-MM-YYYY (non-US based) date formats which is not how above screenshot or file has date field currently formatted.
Sub FormatDates()
For i = 2 To 2083
Range("A" & i) = CDate(Range("A" & i))
Next i
End Sub
Run macro in a different workbook than the one holding the data. Below assumes data workbook holds source information in worksheet named Data.
In query-running workbook, create a blank worksheet named RESULTS which will be populated with query output including column headers.
VBA Script (two connections available Driver (commented out) and Provider versions)
Option Explicit
Sub RunSQL()
Dim cols As Object, datawbk As Workbook, datawks As Worksheet
Dim lastcol As Integer, i As Integer, j As Variant, output As Variant
Set cols = CreateObject("Scripting.Dictionary")
Set datawbk = Workbooks.Open("C:\Path\To\Data\Workbook.xlsx;")
Set datawks = datawbk.Worksheets("Data")
lastcol = datawks.Cells(7, datawks.Columns.Count).End(xlToLeft).Column
For i = 2 To lastcol
cols.Add CStr(i - 1), datawks.Cells(1, i).Value
Next i
datawbk.Close False
Set datawks = Nothing
Set datawbk = Nothing
output = DataCapture(cols)
End Sub
Function DataCapture(datacols As Object)
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim strConnection As String
Dim classSQL As String, itemSQL As String, grpSQL As String, strSQL As String
Dim i As Integer, fld As Object, d As Variant, lastrow As Integer
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' Hard code database location and name '
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=C:\Path\To\Data\Workbook.xlsx;"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Path\To\Data\Workbook.xlsx;" _
& "Extended Properties=""Excel 12.0 XML;HDR=YES IMEX=1;"";"
' OPEN DB CONNECTION '
conn.Open strConnection
For Each d In datacols.keys
strSQL = " SELECT '" & datacols(d) & "' AS [COLUMN], [Data$].[" & datacols(d) & "] AS ITEMS," _
& " SUM(IIF(Year([Item Creation Date]) >= Year(Date()) - 1, 1, 0)) AS NEW," _
& " " _
& " SUM(IIF(Year([Item Creation Date]) < Year(Date()) - 1, 1, 0)) AS OLD," _
& " " _
& " ROUND(SUM(IIF(Year([Item Creation Date]) >= Year(Date()) - 1, 1, 0)) / " _
& " (SELECT Count(*) FROM [Data$] AS sub" _
& " WHERE Year(sub.[Item Creation Date]) >= Year(Date()) - 1),2) AS NEWPCT," _
& " " _
& " ROUND(SUM(IIF(Year([Item Creation Date]) < Year(Date()) - 1, 1, 0)) / " _
& " (SELECT Count(*) FROM [Data$] AS sub" _
& " WHERE Year(sub.[Item Creation Date]) < Year(Date()) - 1),2) AS OLDPCT" _
& " FROM [Data$]" _
& " GROUP BY [Data$].[" & datacols(d) & "]"
' OPEN RECORDSET '
rst.Open strSQL, conn
' COLUMN HEADERS '
If d = 1 Then
i = 0
Worksheets("RESULTS").Range("A1").Activate
For Each fld In rst.Fields
ActiveCell.Offset(0, i) = fld.Name
i = i + 1
Next fld
End If
' DATA ROWS '
lastrow = Worksheets("RESULTS").Cells(Worksheets("RESULTS").Rows.Count, "A").End(xlUp).Row
Worksheets("RESULTS").Range("A" & lastrow + 1).CopyFromRecordset rst
rst.Close
Next d
conn.Close
MsgBox "Successfully processed SQL query!", vbInformation
Exit Function
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Exit Function
End Function
Output
I've been searching for a direct solution, but haven't found anything quite like what I'm attempting to do on this board. I have an Excel worksheet that has several non-contiguous lists of bonds for different companies (think 5 bonds for one company, 3 fully empty rows, then another list of 6 bonds for another company, 5 fully empty rows, etc. etc.).
I'm trying to write an SQL update query that will directly update an Access table in .accdb format. I have fields that have the same name as the column headers in Excel, with the same data.
I need to perform this logic: where range A1 & B1 & C1 are not blank, add a new record to the table that shows A1 & B1 & C1 as fields [Ticker], [Coupon], [Maturity]. Where those cells ARE blank, move to the next row.
Can someone help evaluate my code? I'm getting an error 3343 at the point where I specify "Set db".
My preliminary code is below (scraped together from what I could find online as far as interfacing with Excel and SQL commands):
Sub UpdateDatabase()
Dim x As Integer
Dim strSQL As String
Dim db As Database
Dim dbLocation As String
Dim objConnection As Object
Worksheets("Bonds Clean").Activate
Range("A6").Select
dbLocation = "c:\Folders\Workflow Tables.accdb"
Set objConnection = CreateObject("DAO.DBEngine.36")
Set db = objConnection.OpenDatabase(dbLocation)
For x = 1 To Range(Selection, Selection.End(xlDown)).Rows.Count
If Not (Selection.Value = "") Then
strSQL = "UPDATE tblBonds_Temp SET"
strSQL = strSQL & "Ticker =" & Chr(34) & Selection.Offset(0, 1).Value & Chr(34) & ","
strSQL = strSQL & "Coupon =" & Chr(34) & Selection.Offset(0, 2).Value & Chr(34) & ","
strSQL = strSQL & "Maturity =" & Chr(34) & Selection.Offset(0, 3).Value & Chr(34) & ";"
db.Execute strSQL
Else
End If
Selection.Offset(1, 0).Select
Next
End Sub
DAO.DBEngine.36 is for DAO 3.6 which is suitable for MDB format database files. However, your database is ACCDB format which means that DAO 3.6 won't work. You must use the newer DAO instead.
'Set objConnection = CreateObject("DAO.DBEngine.36")
Set objConnection = CreateObject("DAO.DBEngine.120")
I've been given an Access database which includes 12 tables of data that each contain around 200,000 rows. Each of these tables contain monthly data on about 200 buildings. I don't want to spend a lot of time normalizing the database, I just wrote a quick script to create a table for each building from this data.
Having said all that, my code is taking about 1.5 hours to run. Is there anything I can do to speed this up, or am I just reaching the limits of what Access is capable of? Any suggestions will be appreciated.
Sub RunQueryForEachBuilding()
Dim RRRdb As DAO.Database
Dim rstBuildNames As DAO.Recordset
Dim rstDataTables As DAO.Recordset
Dim rstMonthlyData As DAO.Recordset
Dim strSQL As String
Dim sqlCreateT As String
Dim sqlBuildData As String
Dim strDataTable As String
Dim sqlDrop As String
On Error GoTo ErrorHandler
'open recordsets for building names and datatables
Set RRRdb = CurrentDb
Set rstBuildNames = RRRdb.OpenRecordset("BuildingNames")
Set rstDataTables = RRRdb.OpenRecordset("DataTables")
Do Until rstBuildNames.EOF
' Create a table for each building.
' Check if table exists, if it does delete and recreate.
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & rstBuildNames.Fields("BuildingPath") & "'")) Then
' Table Exists - delete existing
sqlDrop = "DROP TABLE [" & rstBuildNames.Fields("BuildingPath") & "]"
RRRdb.Execute sqlDrop
' re-create blank table
End If
'create table for this building
sqlCreateT = "CREATE TABLE [" & rstBuildNames.Fields("BuildingPath") & _
"] (BuildingPath VARCHAR, [TimeStamp] DATETIME, CHWmmBTU DOUBLE , ElectricmmBTU DOUBLE, kW DOUBLE, kWSolar DOUBLE, kWh DOUBLE, kWhSolar DOUBLE)"
RRRdb.Execute sqlCreateT
'populate data from monthly table into the building name table.
Do While Not rstDataTables.EOF
' get data from each monthly table for this building and APPEND to table.
strDataTable = rstDataTables.Fields("[Data Table]")
'Debug.Print strDataTable
'create a SQL string that only selects records that are for the correct building & inserts them into the building table
sqlBuildData = "INSERT INTO [" & rstBuildNames.Fields("BuildingPath")
sqlBuildData = sqlBuildData & "] ([TimeStamp], [CHWmmBTU], [ElectricmmBTU], kW, [kWSolar], kWh, [kWhSolar], BuildingPath) "
sqlBuildData = sqlBuildData & " SELECT [TimeStamp], [CHW mmBTU], [Electric mmBTU], kW, [kW Solar], kWh, [kWh Solar], BuildingPath FROM "
sqlBuildData = sqlBuildData & rstDataTables.Fields("[Data Table]") & " WHERE BuildingPath LIKE '*" & rstBuildNames.Fields("BuildingPath") & "'"
'Debug.Print sqlBuildData
RRRdb.Execute sqlBuildData
rstDataTables.MoveNext
Loop
rstBuildNames.MoveNext
rstDataTables.MoveFirst
Loop
Set rstBuildNames = Nothing
Set rstDataTables = Nothing
ErrorHandler:
'MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
That code drops and then re-creates rstBuildNames.Fields("BuildingPath") with the same structure. It should be faster to just empty out the table:
"DELETE FROM " & rstBuildNames.Fields("BuildingPath")
However that is not likely to speed up the operation enough.
The WHERE clause of the INSERT query forces a full table scan ...
" WHERE BuildingPath LIKE '*" & rstBuildNames.Fields("BuildingPath") & "'"
If you can use an exact string match instead of a Like comparison, and create an index on BuildingPath, you should see a significant improvement.
" WHERE BuildingPath = '" & rstBuildNames.Fields("BuildingPath") & "'"
I will suggest dbOpenSnapshot, too, even though it won't make a noticeable difference since you're only opening the recordsets one time. (It may not help, but it won't hurt.)
Set rstBuildNames = RRRdb.OpenRecordset("BuildingNames", dbOpenSnapshot)
Set rstDataTables = RRRdb.OpenRecordset("DataTables", dbOpenSnapshot)