Multiple Apps

Convert Column/Feild Names to Cell References for Populating reports

Ease of Use

Intermediate

Version tested with

2000 

Submitted by:

XLGibbs

Description:

As an alternative to using External Data queries, or other methods of populating reports, it is often useful to have a Template.xls report that has your structure, and you just need to populate this template with relevant data from the recordset. This code demonstrates how to use a Query in Access as an example of identifying cell references as column names, and then populating a report using those column names as the data's address. Other data source views and queries, or SQL Statement created recordsets are also applicable provided the column names are cell references. 

Discussion:

You have to generate periodic reports for Salesman, summarizing their data which is housed in an Access database, ODBC Data source like SQL Server, or other ADO capable record source provider. Getting the data is usually the easy part, getting it from the data source into your report is not as simple sometimes. This provides a relatively easy method that can be incorporated into Excel, Access, VB, C#,and FoxPro, and others conceivably. The sample code is written in excel, and the sample files attached have both an Excel method and an Access method for demonstration. 

Code:

instructions for use 

			
 '''EXCEL CODE''''
 '''SET REFERENCE TO Active X DAO Library
 
Option Explicit 
 
Public Type RowColumn 'function requires a user defined type
    row As String 
    col As String 
End Type 
 
 
Public Function GetRowColumn(strRowColumn) As RowColumn 
    Dim lngCount As Long 
    Dim lngChar As String 
     'function to get cell references out of column names where the column names
     ' are equivalent to A1 style cell references  (Note:R1C1 references won't work with this)
    For lngCount = 1 To Len(strRowColumn) 
        lngChar = Asc(Mid(strRowColumn, lngCount, 1)) 
         
        If lngChar >= Asc("0") And lngChar <= Asc("9") Then 
            Exit For 
        End If 
    Next lngCount 
     'this extracts the column and row from the Field Name in the recordset.
     
    GetRowColumn.col = Left(strRowColumn, lngCount - 1) 
    GetRowColumn.row = Right(strRowColumn, Len(strRowColumn) - lngCount + 1) 
     
End Function 
 
Sub GenerateAllReports() 
     'called from button click on Sheet1
     'simply a sample.  The procedure to pass a variable through the Generate report can
     'be called from a form, and excel file, and access file with minor changes, or another
     'program
     
     'dimension variables
    Dim rngNames As Range, c As Range 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.DisplayAlerts = False 
     
    On Error Goto EarlyOut 
     
    With ActiveSheet 
        Set rngNames = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).row) 
         
        For Each c In rngNames 
            GenerateReport c 
             
        Next c 
    End With 
    Set rngNames = Nothing 
     
     
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
    MsgBox "Reports Completed!" 
    Exit Sub 
EarlyOut: 
    MsgBox "Error: " & Err.Number & "  " & Err.Description 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
    Set rngNames = Nothing 
     
End Sub 
Public Sub GenerateReport(ByVal strCriteria As String) 
     'Dimension Variables  NOTE: the criteria for this is passed in as a string,
     ' and can be passed any number of ways.
     
    Dim objExcelApp As Excel.Application 
    Dim objWorkbook As Excel.Workbook 
    Dim objWorksheet As Excel.Worksheet 
     
    Dim objCN As ADODB.Connection 
    Dim objRS As ADODB.Recordset 
    Dim objField As ADODB.Field 
    Dim strSQL As String 
    Dim udtRowColumn As RowColumn 
    Dim strPath As String 
    Dim strConn As String 
    Dim strFileName As String 
     
    strPath = ThisWorkbook.Path 'sets the path of the file for use later
     
    Set objExcelApp = New Excel.Application 'sets object as new instance of excel
     
    Set objWorkbook = objExcelApp.Workbooks.Open(strPath & "\ReportTemplate\" & "Template.xls") 
     'above opens the file in the new instance
     
    Set objWorksheet = objWorkbook.ActiveSheet 'sets the destination sheet
     
    Set objCN = New ADODB.Connection 'sets a new connection in memory
     
     'string connection here
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & "\" & "GetColumnRow.mdb;Persist Security Info=False" 
     
    objCN.ConnectionString = strConn 'set the connection
    objCN.Open 'open the connection
     
     'remember to use the "column Name" to identify criteria field...
     
    strSQL = "SELECT * FROM ReportQuery WHERE [A2] =" & Chr(34) & strCriteria & Chr(34) 
     'remember to format the criteria string properly to match the record source format..
     
     'SQL statement.  if already in Access it could be DoCmd.RunSQL
     
    Set objRS = New ADODB.Recordset 
    objRS.Open strSQL, objCN, adOpenForwardOnly, adLockReadOnly, adCmdText 
     
    On Error Goto ErrHandler 
    For Each objField In objRS.Fields 'for each column in result set
         
        If IsNumeric(Right(objField.Name, 1)) Then 
            udtRowColumn = GetRowColumn(objField.Name) 
             
            objWorksheet.Cells(udtRowColumn.row, udtRowColumn.col) = objField.Value 
        End If 
         'gets the cell reference from the column/feild name of the result set
         
    Next objField 'next field
     
    objRS.Close 'close recordset
    Set objRS = Nothing 'clear the recordset from memory
     
    objCN.Close 'cease the connection
    Set objCN = Nothing 'clear the object
     
     'save the report to a specified path with date formatted string
    strFileName = strPath & "\Reports\" & strCriteria & "_" & Format(Now(), "mmddyy") & ".xls" 
    objWorkbook.SaveAs strFileName 
    objWorkbook.Close 
     
     'clear the excel variable objects
    Set objWorksheet = Nothing 
    Set objWorkbook = Nothing 
    Set objExcelApp = Nothing 
    Set objCN = Nothing 
    Set objRS = Nothing 
    Set objField = Nothing 
     
    Exit Sub 
ErrHandler: 
     'to clear the hidden objWorkbook from memory...and resume
    objWorkbook.Close 
    Set objWorksheet = Nothing 
    Set objWorkbook = Nothing 
    Set objExcelApp = Nothing 
     
    Resume Next 
     
End Sub 
 
 
 
 ''''MICROSOFT ACCESS CODE'''
 ''SET REFERENCE TO MICROSOFT EXCEL OBJECT LIBRARY
 
Option Compare Database 
Option Explicit 
Public Type RowColumn 'function requires a user defined type
    row As String 
    col As String 
End Type 
 
 
Public Function GetRowColumn(strRowColumn) As RowColumn 
    Dim lngCount As Long 
    Dim lngChar As String 
     'function to get cell references out of column names where the column names
     ' are equivalent to A1 style cell references  (Note:R1C1 references won't work with this)
    For lngCount = 1 To Len(strRowColumn) 
        lngChar = Asc(Mid(strRowColumn, lngCount, 1)) 
         
        If lngChar >= Asc("0") And lngChar <= Asc("9") Then 
            Exit For 
        End If 
    Next lngCount 
     'this extracts the column and row from the Field Name in the recordset.
     
    GetRowColumn.col = Left(strRowColumn, lngCount - 1) 
    GetRowColumn.row = Right(strRowColumn, Len(strRowColumn) - lngCount + 1) 
     
End Function 
Public Sub GenerateReport(ByVal strCriteria As String) 
     'Dimension Variables  NOTE: the criteria for this is passed in as a string,
     ' and can be passed any number of ways.
     
    Dim objExcelApp As Excel.Application 
    Dim objWorkbook As Excel.Workbook 
    Dim objWorksheet As Excel.Worksheet 
    Dim ObjRS1 As Recordset 
    Dim objField As Field 
    Dim strSQL As String 
    Dim udtRowColumn As RowColumn 
    Dim strPath As String 
    Dim strConn As String 
    Dim strFileName As String 
     
    strPath = CurrentProject.Path 'sets the path of the file for use later
     
    Set objExcelApp = New Excel.Application 'sets object as new instance of excel
     
    Set objWorkbook = objExcelApp.Workbooks.Open(strPath & "\ReportTemplate\" & "Template.xls") 
     'above opens the file in the new instance
     
    Set objWorksheet = objWorkbook.ActiveSheet 'sets the destination sheet
     
     'remember to use the "column Name" to identify criteria field...
     
    strSQL = "SELECT * FROM ReportQuery WHERE [A2] =" & Chr(34) & strCriteria & Chr(34) 
     'remember to format the criteria string properly to match the record source format..
     
     'SQL statement.  if already in Access it could be DoCmd.RunSQL
     
    Set ObjRS1 = New Recordset 
    ObjRS1.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly, adCmdText 
     
    On Error Goto ErrHandler 
    For Each objField In ObjRS1.Fields 'for each column in result set
         
        If IsNumeric(Right(objField.Name, 1)) Then 
            udtRowColumn = GetRowColumn(objField.Name) 
             
            objWorksheet.Cells(udtRowColumn.row, udtRowColumn.col) = objField.Value 
        End If 
         'gets the cell reference from the column/feild name of the result set
         
    Next objField 'next field
     
    ObjRS1.Close 'close recordset
    Set ObjRS1 = Nothing 'clear the recordset from memory
     
     'save the report to a specified path with date formatted string
    strFileName = strPath & "\Reports\" & strCriteria & "_" & Format(Now(), "mmddyy") & ".xls" 
    objWorkbook.SaveAs strFileName 
    objWorkbook.Close 
     
     
     'clear the excel variable objects
    Set objWorksheet = Nothing 
    Set objWorkbook = Nothing 
    Set objExcelApp = Nothing 
     
     
     
    Exit Sub 
ErrHandler: 'if it errors, the ExcelApp remains in the background, but this clears it and resumes the code
    objWorkbook.Close 
    Set objWorksheet = Nothing 
    Set objWorkbook = Nothing 
    Set objExcelApp = Nothing 
    Err.Clear 
    Resume Next 
     
End Sub 
 
Sub GenerateAllReports() 
     
    Dim objRS As ADODB.Recordset, strSQL As String 
     
    strSQL = "Select Employee_Name from Employee Group By Employee_Name" 
     
    Set objRS = New Recordset 
     
    objRS.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockReadOnly, 1 
     
    Do While Not objRS.EOF 
        GenerateReport objRS![Employee_Name] 
        objRS.MoveNext 
    Loop 
     
    Set objRS = Nothing 
     
    MsgBox "Reports Completed!" 
End Sub

How to use:

  1. 1.Relies on a recordset that can be queried. To use the GetRowColumn method, you must have a recordset that identifies the cell references as column names, and an excel template that can receive the data properly(although a blank excel file would take the values as well)
  2. 2. The Excel code can be placed in a standard Module by selecting the Visual Basic Editor from Tools>Macro>Visual Basic editor or hitting Alt-F11.
  3. 3.Access code also goes in a standard Module. In the database window, select modules > New and paste the Access code.
  4. 4. Specify the proper source data connection string, SQL statement,and applicable table/query names you intend to use.
  5. 5.This is designed for row level data in summary format to be fed into a report in a predefined format where the cell references are assigned properly as column names.
  6. 5. The sample files attached have working examples.
 

Test the code:

  1. 1.Download the attached folder and extract.
  2. 2. Open the Excel file and press the button. OR Open the Access database and press the button on Form1 to generate the reports inot the template.xls file provided
  3. 3. The source database shows a "NormalQuery" and a "ReportQuery" to show the concept of naming the columns. Both sample codes show how the SQL Statment can be written.
  4. 4.The attached folder is set up as it needs to be, once you run either set of reports, go to the Reports folder to view them (folder is currently empty)
 

Sample File:

GetRowColumn.zip 271.73KB 

Approved by mdmackillop


This entry has been viewed 104 times.

Please read our Legal Information and Privacy Policy
Copyright? 2004 - 2005 VBA Express