Create Excel Sheets (1 Viewer)

[Crilen007]

Ok..

I firstly just need to know if this is possible.. and if so.. if anyone has any example programs on how this can be done.

I have to create a large number of excel sheets with data from tables.

I need to have formatting (Image at the top, certain lines have to be highlighted.. etc).

Can Access export into excel with formatting? Or can I do it through VBA?

I need to have a lot of workbooks, most of them need multiple sheets.

I've never really had to work with access and excel in this way. Usually I have excel read an Access database, or have Access link/import an excel sheet.

I've never had to generate many sheets like this before.

Anyways, thanks for the help.

 

[The_Doc_Man]

There are two paths to Excel from Access. You have used the "Export" path (from your description).

The other path is the Application Object path. Read up on the help files regarding application objects. You want to open an Excel object (essentially, a child session containing Excel). Once you do, the object's exposed methods allow you to open a workbook, select a worksheet, and start doing at least a few things directly.

A workbook contains a collection of worksheets. A worksheet contains a ton of collections including CELLS, ROWS, COLUMNS, etc. Cells are not JUST empty slots. They have formatting attributes, text ranges, etc. Study the help on this very carefully before attempting to muck about. To help you find what you need, I suggest you also open the EXCEL help files to find the part about VBA programming and features because the Access help isn't quite as good about examples of collection traversal for Excel objects.

As I recall, the nastiest part about mucking around in Excel is that unless you declare a couple of WorkSheet objects to shorten the reference path, you tend to get really nasty object references like

XLObj.Workbook(1).Worksheet(2).Row(3).Cell(4).Range.Text

in order to see the contents of cell A3 of Sheet 2 of your workbook. And it has been long enough that I don't doubt I left something out of that somewhere. But I think you get the picture. Declaring a WorkSheet object allows you to do a SET like

SET WkSht = XLObj.Workbook(1).Worksheet(2)

and then use WkSht.Row()...

 

[Crilen007]

Wow... it's going to get nasty isn't it...
heh

Wonder if there are any examples anywhere.

Any keywords you could suggest for finding an example DB that creates excel sheets that are more complicated than a simple export?

 

[The_Doc_Man]

Wow... it's going to get nasty isn't it...

Very.

Wonder if there are any examples anywhere.

I don't recall seeing one. However, I am limited in what I can see because my main site won't allow me to download anything that might contain code.

Any keywords you could suggest

I'm drawing a blank here. Other posters?

 

[Dennisk]

Example

Here is an example.
using a template Worksheet


Private Sub btnCreateChangeRequest_Click()
'
' Routine to Generate a new Reference Number
' Copy the blank Change/request Form (.XLS) to 'SpreadsheetName/Year/Month/Number in the Folder \MailOut
' Then open the spreadsheet and insert the ReferenceNumber and Date
'
Dim rst As Recordset
Dim txtReferenceNumber As String
Dim WkBk As Excel.Workbook
Dim strPath As String
Dim ExcelApp As Excel.Application

On Error GoTo Err_Handler
If MsgBox("Do you wish to create a new Change Request form", vbInformation + vbYesNo) = vbYes Then
If IsValid() Then
Set ExcelApp = CreateObject("Excel.Application")

strPath = GetPathToFE()
txtReferenceNumber = Format(Date, "yyyymm") & Format(GetNextAutoNumber(), "0000")
FileCopy strPath & "\ChangeRequestV0.4.xls", strPath & "\MailOut\ChangeRequest" & txtReferenceNumber & ".xls"

Set WkBk = ExcelApp.Workbooks.Open(FileName:=strPath & "\MailOut\ChangeRequest" & txtReferenceNumber & ".xls")
WkBk.Sheets(1).Unprotect

WkBk.Sheets(1).Range("B3").Locked = False
WkBk.Sheets(1).Range("B3").Value = txtReferenceNumber
WkBk.Sheets(1).Range("B3").Locked = True

WkBk.Sheets(1).Range("B4").Locked = False
WkBk.Sheets(1).Range("B4").Value = Me!cboDept.Column(1)
WkBk.Sheets(1).Range("B4").Locked = True

WkBk.Sheets(1).Range("B6").Locked = False
WkBk.Sheets(1).Range("B6").Value = Date
WkBk.Sheets(1).Range("B6").Locked = True

WkBk.Sheets(1).Protect
WkBk.Save


txtLastNumberAllocated = txtReferenceNumber
'finally...
If Not (ExcelApp Is Nothing) Then
ExcelApp.Quit
End If

Set rst = CurrentDb.OpenRecordset("tblChangeControlDocument")
rst.AddNew
rst("ChangeControlID") = txtReferenceNumber
rst("DepartmentID") = Me!cboDept
rst("DateRequestSubmitted") = Now()
rst("DateTimeStamp") = Now()
rst.Update
End If
End If

Exit_Handler:
Set WkBk = Nothing
Set ExcelApp = Nothing
Exit Sub

Err_Handler:
MsgBox Err.Description
Resume Exit_Handler

 

[Crilen007]

Ah, very cool.

Gives me a great place to start.

If I could have the excel sheet open, and run an update query that had Access fill in the values. I could have access create the query with proper filters, then have acces make a copy of the template, save it with a proper name, then make it do a data update, it would be perfect!

Yes, I think i got this figured out!

 

[Moniker]

I was going to highly suggest making a template that has a lot of the formatting done for you. It's not really too difficult to do this through programming; it's more tedious than anything else.

This is a collection of routines that, when used with the correct parameters, will output to an existing template, modifying it as necessary (adding rows, changing headers, etc.). It's not functional on its own (that's intentional) but it may give you some ideas on how I was adding rows/columns, moving things around, addressing ranges, etc. so that I could get the output to be "just so".

Note these are each a subroutine, all called from a main routine, which means it's modular. Instead of keeping my main routine one big brain dump (which I usually initially do), I like to go back and clean it up to make maintenance easier. This way, the main code looks like this:

    Set xlApp = New Excel.Application
    xlApp.DisplayAlerts = False
    xlApp.AskToUpdateLinks = False
    Set xlWkbk = xlApp.Workbooks.Open(CurrentProject.Path & "\TemplateFileName.xls")
    
    Call BuildExcelSheetTop("xxx")
    Call BuildRateGroups("xxx", "xxx")
    Call BuildReconciliation
    Call BuildSummary
    Call BuildDetail("xxx", "xxx")
    
    xlWkbk.SaveAs xlFileName
    xlApp.Quit

Just looking at that, it's clear and concise what it's doing, so if any part of it isn't right, tracking down the error is much easier. (For example, if the Summary isn't right, I'm 99% positive the error will be in the "BuildSummary" routine.) The hairier part is below (the actual called subroutines). Again, it's more tedium than anything, but it can be a little confusing.

Sub BuildExcelSheetTop(SheetName As String)

    Dim rsSystem As Recordset
    Dim TempMonth As Integer
    Dim TempYear As Integer
    
    Set xlSht = xlWkbk.Worksheets(SheetName)
    
    Set rsSystem = New Recordset
    With rsSystem
        .Open "SELECT * FROM t_System", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        xlSht.Range("'" & SheetName & "'!PIN").Value = .Fields("PIN").Value
        xlSht.Range("'" & SheetName & "'!SCM").Value = .Fields("SCM").Value
        xlSht.Range("'" & SheetName & "'!Hospital").Value = .Fields("FacilityName").Value
        xlSht.Range("'" & SheetName & "'!Market").Value = .Fields("Market").Value
        xlSht.Range("'" & SheetName & "'!StartDate").Value = Format(.Fields("StartDate").Value, "mm-dd-yy")
        xlSht.Range("'" & SheetName & "'!EndDate").Value = fDate_Convert("LastDay", Format(.Fields("EndDate").Value, "mm-dd-yy"))
        xlSht.Range("'" & SheetName & "'!AdjDate").Value = .Fields("AdjDate").Value
        xlSht.Range("'" & SheetName & "'!RenewalDate").Value = .Fields("RenewalDate").Value
        TempYear = Year(.Fields("EndDate").Value) - Year(.Fields("StartDate").Value)
        TempYear = TempYear * 12
        TempMonth = Month(.Fields("EndDate").Value) - Month(.Fields("StartDate").Value)
        TempMonth = TempMonth + 1
        xlSht.Range("'" & SheetName & "'!O3").Value = TempMonth + TempYear
        gYearCalc = Year(.Fields("AdjDate").Value)
        gFirstMonth = 13 - Month(.Fields("AdjDate").Value)
        gSecondMonth = 12 - gFirstMonth
        gThirdMonth = 0
        .Close
    End With
    
End Sub

Sub BuildRateGroups(SheetName As String, strSQLSuffix As String)

    Dim rsMap As Recordset
    Dim RateGroupCount As Integer
    Dim HMOCount As Integer
    Dim NonHMOCount As Integer
    Dim RowLoop As Long
    
    Set rsMap = New Recordset
    With rsMap
        .Open "SELECT * from t_Map", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        RateGroupCount = .RecordCount
        If RateGroupCount < 1 Then
            MsgBox "Please set the parameters before starting the download process.", vbOKOnly, "Rate Group Missing"
            Exit Sub
        End If
        .Close
        .Open "SELECT DISTINCT t_Results_Detail.PROD, t_Results_Detail.RATEGRP FROM t_Results_Detail WHERE Prod = 'HMO' AND RATEGRP IS NOT NULL" & strSQLSuffix, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        HMOCount = .RecordCount
        .Close
        .Open "SELECT DISTINCT t_Results_Detail.PROD, t_Results_Detail.RATEGRP FROM t_Results_Detail WHERE Prod <> 'HMO' AND RATEGRP IS NOT NULL" & strSQLSuffix, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        NonHMOCount = .RecordCount
        .Close
    End With
    
    'Add space for additional rate group lines on the template.
    Set xlSht = xlWkbk.Worksheets(SheetName)
                
    With xlSht
        If HMOCount > 1 Then
            For RowLoop = 1 To HMOCount - 1
                .Range("'" & SheetName & "'!HMOCalcRow").Copy
                .Range("'" & SheetName & "'!HMOCalcRow").Insert xlShiftDown
            Next
        End If
        
        If NonHMOCount > 1 Then
            For RowLoop = 1 To NonHMOCount - 1
                .Range("'" & SheetName & "'!NonHMOCalcRow").Copy
                .Range("'" & SheetName & "'!NonHMOCalcRow").Insert xlShiftDown
            Next
        End If
    End With

    Select Case SheetName
        Case "CM Savings-ALL"
            gHMOCountAll = HMOCount
            gNonHMOCountAll = NonHMOCount
        Case "CM Savings-FI ONLY"
            gHMOCountFI = HMOCount
            gNonHMOCountFI = NonHMOCount
        Case Else
    End Select

End Sub

Sub BuildReconciliation()

    Dim rsSummary As Recordset
    Dim ColCount As Integer
    Dim RowCount As Long
    Dim ColLoop As Integer
    Dim RowLoop As Long
    
    Set xlSht = xlWkbk.Worksheets("Reconciliation")
    xlSht.PageSetup.LeftFooter = xlFileName
    xlSht.Range("A1:AZ65536").ClearContents
    
    Set rsSummary = New Recordset
    With rsSummary
        .Open "SELECT EPDB_PIN, PROD, FUNDING, DOSMO, RATEGRP, NEWRATEGRP, BILLED_AMT FROM t_Results_Detail ORDER BY EPDB_PIN, PROD, FUNDING, DOSMO, RATEGRP, NEWRATEGRP", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        If .EOF Then
            MsgBox "No data was returned for the criteria you selected.", vbOKOnly, "No Data Found"
            Exit Sub
        End If
        ColCount = .Fields.Count
        RowCount = .RecordCount
        
        .MoveFirst
        For ColLoop = 0 To ColCount - 1
            xlSht.Cells(1, ColLoop + 1).Value = .Fields(ColLoop).Name
        Next
        For RowLoop = 0 To RowCount - 1
            For ColLoop = 0 To ColCount - 1
                xlSht.Cells(RowLoop + 2, ColLoop + 1).Value = .Fields(ColLoop).Value
            Next
            .MoveNext
        Next
        .Close
    End With
    Set rsSummary = Nothing

End Sub

Sub BuildSummary()

    Dim rsSummary As Recordset
    Dim ColCount As Integer
    Dim RowCount As Long
    Dim ColLoop As Integer
    Dim RowLoop As Long
    
    Set xlSht = xlWkbk.Worksheets("Summary")
    xlSht.PageSetup.LeftFooter = xlFileName
    xlSht.Range("A1:AZ65536").ClearContents
    
    Set rsSummary = New Recordset
    With rsSummary
        .Open "SELECT EPDB_PIN, PROD, FUNDING, RG, NEWRG, BILLED_AMT FROM q_Results_Summarized", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        If .EOF Then
            MsgBox "No data was returned for the criteria you selected.", vbOKOnly, "No Data Found"
            Exit Sub
        End If
        ColCount = .Fields.Count
        RowCount = .RecordCount
        
        .MoveFirst
        For ColLoop = 0 To ColCount - 1
            xlSht.Cells(1, ColLoop + 1).Value = .Fields(ColLoop).Name
        Next
        For RowLoop = 0 To RowCount - 1
            For ColLoop = 0 To ColCount - 1
                xlSht.Cells(RowLoop + 2, ColLoop + 1).Value = .Fields(ColLoop).Value
            Next
            .MoveNext
        Next
        .Close
    End With
    
End Sub

Sub BuildDetail(SheetName As String, strSQLSuffix As String)

    Dim rsSummary As Recordset
    Dim HMOCount As Integer
    Dim NonHMOCount As Integer
    Dim RowLoop As Long
    Dim strSQL As String
    
    Set rsSummary = New Recordset
        
    Select Case SheetName
        Case "CM Savings-ALL"
            HMOCount = gHMOCountAll
            NonHMOCount = gNonHMOCountAll
            strSQL = "SELECT * FROM q_Results_Summarized_ByProdRG"
        Case "CM Savings-FI ONLY"
            HMOCount = gHMOCountFI
            NonHMOCount = gNonHMOCountFI
            strSQL = "SELECT * FROM q_Results_Summarized_FI_ONLY"
        Case Else
    End Select
    
    Set xlSht = xlWkbk.Worksheets(SheetName)
    
    With rsSummary
        xlSht.PageSetup.LeftFooter = xlFileName
        xlSht.Range("J9").Value = gYearCalc & " Contract Period"
        xlSht.Range("L9").Value = gYearCalc + 1 & " Contract Period"
        xlSht.Range("N9").Value = gYearCalc + 2 & " Contract Period"
        
        .Open strSQL & " WHERE PROD = 'HMO'", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        If Not (.EOF) Then
            If HMOCount > 1 And .RecordCount > 1 Then
                .MoveFirst
                For RowLoop = 0 To HMOCount - 1
                    xlSht.Range("A11").Offset(RowLoop).Value = fFormatRG(.Fields("RateGrp").Value)
                    xlSht.Range("C11").Offset(RowLoop).Value = .Fields("Billed_Amt")
                    xlSht.Range("D11").Offset(RowLoop).Value = .Fields("SumOfBilled_Amt_In_RG").Value
                    xlSht.Range("G11").Offset(RowLoop).Value = fFormatRG(.Fields("NewRateGrp").Value)
                    xlSht.Range("J11").Offset(RowLoop).Value = gFirstMonth
                    xlSht.Range("L11").Offset(RowLoop).Value = gSecondMonth
                    xlSht.Range("N11").Offset(RowLoop).Value = gThirdMonth
                    .MoveNext
                Next
            Else
                xlSht.Range("A11").Value = fFormatRG(.Fields("RateGrp").Value)
                xlSht.Range("C11").Value = .Fields("Billed_Amt")
                xlSht.Range("D11").Value = .Fields("SumOfBilled_Amt_In_RG").Value
                xlSht.Range("G11").Value = fFormatRG(.Fields("NewRateGrp").Value)
                xlSht.Range("J11").Value = gFirstMonth
                xlSht.Range("L11").Value = gSecondMonth
                xlSht.Range("N11").Value = gThirdMonth
            End If
        End If
        .Close
        
        .Open strSQL & " WHERE PROD = 'NonHMO'", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
        If HMOCount < 1 Then
            HMOCount = 1
        End If
        If Not (.EOF) Then
            If NonHMOCount > 1 And .RecordCount > 1 Then
                .MoveFirst
                For RowLoop = 0 To NonHMOCount - 1
                    xlSht.Range("A19").Offset(RowLoop + (HMOCount - 1)).Value = fFormatRG(.Fields("RateGrp").Value)
                    xlSht.Range("C19").Offset(RowLoop + (HMOCount - 1)).Value = .Fields("Billed_Amt")
                    xlSht.Range("D19").Offset(RowLoop + (HMOCount - 1)).Value = .Fields("SumOfBilled_Amt_In_RG").Value
                    xlSht.Range("G19").Offset(RowLoop + (HMOCount - 1)).Value = fFormatRG(.Fields("NewRateGrp").Value)
                    xlSht.Range("J19").Offset(RowLoop + (HMOCount - 1)).Value = gFirstMonth
                    xlSht.Range("L19").Offset(RowLoop + (HMOCount - 1)).Value = gSecondMonth
                    xlSht.Range("N19").Offset(RowLoop + (HMOCount - 1)).Value = gThirdMonth
                    .MoveNext
                Next
            Else
                xlSht.Range("A19").Offset(HMOCount - 1).Value = fFormatRG(.Fields("RateGrp").Value)
                xlSht.Range("C19").Offset(HMOCount - 1).Value = .Fields("Billed_Amt")
                xlSht.Range("D19").Offset(HMOCount - 1).Value = .Fields("SumOfBilled_Amt_In_RG").Value
                xlSht.Range("G19").Offset(HMOCount - 1).Value = fFormatRG(.Fields("NewRateGrp").Value)
                xlSht.Range("J19").Offset(HMOCount - 1).Value = gFirstMonth
                xlSht.Range("L19").Offset(HMOCount - 1).Value = gSecondMonth
                xlSht.Range("N19").Offset(HMOCount - 1).Value = gThirdMonth
            End If
        End If
        
        xlSht.Range("A16").Offset(HMOCount - 1).RowHeight = 25.5
        xlSht.Range("A17").Offset(HMOCount - 1).RowHeight = 25.5
        xlSht.Range("A18").Offset(HMOCount - 1).RowHeight = 38.25
    
        xlSht.Range("J17").Offset(HMOCount - 1).Value = gYearCalc & " Contract Period"
        xlSht.Range("L17").Offset(HMOCount - 1).Value = gYearCalc + 1 & " Contract Period"
        xlSht.Range("N17").Offset(HMOCount - 1).Value = gYearCalc + 2 & " Contract Period"
    End With

End Sub

Function fFormatRG(NewRG As Single)

    fFormatRG = Format(NewRG, "0.0000")

End Function

Not so bad, eh?

HTH.

 

[Crilen007]

Can someone post a sample database of this working?

I guess I don't have the correct references or something.

 

[GaryPanic]

can someone also keep me inthe loop on this as this looks smarter than what I am doing which is make table export out

g