VBA To Loop Access Table and Place Data in Excel Template

[jhabey01]

Hello,
Attached is a Access Database which will process the Data (By the field called GroupName)in the TA_Accident_NewEnrollment table and create four separate excel files each uniquly named based on the Group Name. My goal is to instead get this data onto the Excel file called Accident at the 13 row and then save the file as TA_AccidentEnrollment_Name of Group.xlsm. Go to the next Group and do the same thing until it has done this with all the GroupNames.
Thanks

 

[jhabey01]

Here is the Template Excel file...

 

[dhookom]

How far have you progressed? What have you tried?


Duane
Hook'D on Access
MS Access MVP

 

[jhabey01]

Here is code that puts the data into the Template excel file at row 13. I just have not found a way to combine the code in DB I uploaed with this:

Private Sub Command3_Click()
'Accident
Dim appExcel As Excel.Application
Dim rst As DAO.Recordset
Dim MyDB As DAO.Database
Dim grpname As String

'********************** USER DEFINED SECTION **********************
Const conTABLE_NAME As String = "TA_Accident_NewEnrollment"
Const conSHEET As String = "CI Advance_Acc Adv_LL"
Const conPATH_TO_WORKSHEET As String = _
"C:\Users\John\Desktop\EnrollmentWorksheets\Accident.xlsm"
Const conROW_TO_START As Integer = 13
'******************************************************************

'Make sure to Set a Reference to the Microsoft Excel XX.X Object Library
Set MyDB = CurrentDb
Set rst = MyDB.OpenRecordset(conTABLE_NAME)
Set appExcel = CreateObject("Excel.Application")

With appExcel
.Visible = True
.UserControl = True
With .Workbooks.Open(conPATH_TO_WORKSHEET)
.Worksheets(conSHEET).Range("A13:bJ1000").ClearContents '80 Columns/1,000 Rows
.Worksheets(conSHEET).Activate
.Worksheets(conSHEET).Range("A" & CStr(conROW_TO_START)).CopyFromRecordset rst
.Worksheets(conSHEET).Range("C4").Value = .Worksheets(conSHEET).Range("bc13")
.Worksheets(conSHEET).Range("c6").Value = .Worksheets(conSHEET).Range("bb13")
.Worksheets(conSHEET).Range("BB13:BC20").Value = ""
.Worksheets(conSHEET).Range("A13").Select

grpname = .Worksheets(conSHEET).Range("C4").Value
ActiveWorkbook.SaveAs FileName:= _
"C:\Users\Desktop\TaEnrollments_" & grpname & " .xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End With
End With

rst.Close
Set rst = Nothing
Set appExcel = Nothing
End Sub

 

[dhookom]

I'm not willing to download the file and have less Excel knowledge than lots of others.

Duane
Hook'D on Access
MS Access MVP

 

[SkipVought]

You opened the table. So the entire table will be copied to row 13...

Set rst = MyDB.OpenRecordset(conTABLE_NAME)

 

[SkipVought]

BTW, if the table contains more data (groups) than you want, no need to loop. Just query to return only those groups and *BANG* copyfromrecordset to row 13.

 

[jhabey01]

dhookom: Not sure what you meant by your reply:I'm not willing to download the file and have less Excel knowledge than lots of others.

 

[jhabey01]

Again the attached is database processes the Data (By the field called GroupName)in the TA_Accident_NewEnrollment table and create four separate excel files each uniquly named based on the Group Name. My goal is to instead get this data onto the Excel file called Accident at the 13 row and then save the file as TA_AccidentEnrollment_Name of Group.xlsm. Go to the next Group and do the same thing until it has done this with all the GroupNames.
The code that is working and places each group in separete file is as follows: (What is does not do is and what I want is to Open an existing excel file Named Accident place the data in row 13 save the excel file as TaNewEnrollment_"Name of Group". Close the Existing Excel file and do the same thing for the next three groups. So it is some sor of both sets of code.

Private Sub Command10_Click()
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim v As String

Set db = CurrentDb()
Set rs1 = db.OpenRecordset("select distinct [GroupName] from TA_Accident_NewEnrollment")

Dim strqry As String
Dim qdftemp As DAO.QueryDef
Dim strQdf As String
Do While Not rs1.EOF
strQdf = "_TempQuery_"

v = rs1.Fields(0).Value
strQdf = v

strqry = "select * from TA_Accident_NewEnrollment where [GroupName] = '" & v & "'"
Set qdftemp = CurrentDb.CreateQueryDef(strQdf, strqry)
qdftemp.Close
Set qdftemp = Nothing

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, strQdf, "C:\Users\TAEnrollments_" & v & ".xls", True
CurrentDb.QueryDefs.Delete strQdf
rs1.MoveNext
Loop
rs1.Close

MsgBox "Process Complete. Thanks."

End Sub

 

[dhookom]

What I meant was I typically don't download other's files unless I have a fair amount of time and patience. And, guys like Skip are more knowledgeable than I am.

Duane
Hook'D on Access
MS Access MVP

 

[SkipVought]

Again, unless I have totally missed something, you need no loop!

Is all your group data in one table, or do you have group(s) in different tables?

Please comment on my posts.

 

[jhabey01]

All the groups are in one table. I may upwards of 25 groups in the table and the number of groups can vary week to week. I was thinking of pulling the data by using a select distinct by group and all of the rows of data with that group would get copied to the excel file at the 13th row file renamed and saved and then go to the next group and do the same thing. Thats kind of what the code does from the post at 19 Feb 15 00:35. except that it does not copy it to an existing excel file, it just creates new files with the correct data from that particular group.

 

[SkipVought]

Did you read my previous posts?

 

[jhabey01]

yes I read your previous posts:

You opened the table. So the entire table will be copied to row 13...
Set rst = MyDB.OpenRecordset(conTABLE_NAME) --> This does work except that like you said and all of the contents will be copied to row 13, I have multiple group in the table and only want one group in one excel file to be copied at a time

You also mentioned that: if the table contains more data (groups) than you want, no need to loop. Just query to return only those groups and *BANG* copyfromrecordset to row 13. --> yes this works as I have that code in place but if the table contains 4 groups than I still want a separate excel file for each group. One week I could have 5 groups and would need five different files, the next week I could 12 groups meaning I need 12 files

 

[SkipVought]

Your loop will be based on a query of distinct groups.

You then need a parameter query where group the parameter. Open the Accident workbook, CopyFromRecordset to A13, SaveAs using the group, close the workbook.

 

[jhabey01]

Hi,
I wanted to post and share this solution that Stephen Cooper helped me get through. Estimated time savings per week is about 1.5hrs. Thank you Stephen

The Process: Each week I have multiple enrollment excel files that I get from our source data and are placed into a folder. Each file contains one group or Company. Each group can have members enrolling in five different products, I need to send these enrollments to another company in a particular format and particular mapping. An Access Db Picks up each of those excel files and maps the data and places each product type into its own table. Ther tables are now correctly mapped. The Compnay I send these enrollments to wants one enrollment file for each each group by product in excel, and this is what the code does for just one of those products:

Private Sub New_Accident_Click()
'

'Author: Stephen Cooper
'Email: @consultant.com
'Ph:
'In parameters
'Output
'Description: Will loop a query and export to multiple files



On Error GoTo HandleError:

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim strFolderName As String
Dim strFileName As String
Dim strOutputPath As String
Dim strTemplateName As String
Dim strTemplatePath As String
Dim objFSO As Object
Dim strCompanyName As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim intStartRow As Integer
Dim strSQLData As String
Dim objXLApp As Object
Dim objXLBook As Object
Dim objXLMainSheet As Object
Dim rstData As DAO.Recordset

intMouseType = Screen.MousePointer

DoCmd.Hourglass True

Set db = CurrentDb

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Inserts the data beginning at row
intStartRow = 12

strTemplatePath = "R:\Admin Services\"
strTemplateName = "RA_Accident.xlsm"
strOutputPath = "R:\Admin Services\Reporting\"
strSQL = "select distinct [GroupName] from RA_Accident_NewEnrollment"

Set rst = db.OpenRecordset(strSQL)

'Now need to get a copy of the file
Do While Not rst.EOF
'strCompanyName = rst.Fields("GroupName").Value
strCompanyName = Replace(rst.Fields("GroupName").Value, ",", "")
strFileName = strOutputPath & "RA_NewEnrollment_Accident_" & strCompanyName & ".xlsm"

'Delete if it exists
If objFSO.FileExists(strOutputPath & "RA_NewEnrollment_Accident_" & strCompanyName & ".xlsm") Then
objFSO.deletefile strOutputPath & "RA_NewEnrollment_Accident_" & strCompanyName & ".xlsm"
End If

'Get new file
objFSO.copyfile strTemplatePath & strTemplateName, strOutputPath & "RA_NewEnrollment_Accident_" & strCompanyName & ".xlsm"

'Now get recordset
'swap these around - build SQL string before opening recordset
strSQLData = "select * from RA_Accident_NewEnrollment where Replace([GroupName],',','') = '" & strCompanyName & "'"
Set rstData = db.OpenRecordset(strSQLData)

'rstData = db.OpenRecordset(strSQLData)
' rstData = db.OpenRecordset(strSQLData)

Set objXLApp = CreateObject("Excel.Application")

'Make it non visible. Speeds it up
objXLApp.Application.Visible = True

'Coop - 20/11/2014 - turn off events, so the file isnt looking for an ini file that isnt there yet.
objXLApp.EnableEvents = False

Set objXLBook = objXLApp.Workbooks.Open(strOutputPath & "RA_NewEnrollment_Accident_" & strCompanyName & ".xlsm", False, False)


Set objXLMainSheet = objXLBook.Worksheets("CI Advance_Acc Adv_LL")

'Set some values on the main sheet
With objXLMainSheet

.Cells(intStartRow + 1, 1).CopyFromRecordset rstData
'copies the data in cel bc and places it in C4
'Copies the data in bb13 and places it in c6 if the value in cell bc13 is not HealthAlliance
If .Range("bc13").Value <> "HealthAlliance" Then
.Range("C4").Value = .Range("bc13")
.Range("c6").Value = .Range("bb13")
.Range("BB13:BC500").Value = ""
.Range("A12").Select

End If

End With
objXLBook.Save
objXLBook.Close
rst.MoveNext
Loop

ExitHere:
On Error Resume Next
'Close all recordsets etc here
varReturn = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = intMouseType
objXLApp.Close
Set objXLApp = Nothing
Set objXLBook = Nothing
rstData.Close
Set rstData = Nothing
Exit Sub

HandleError:

Resume ExitHere

MsgBox "Process Complete..."
End Sub