Option Explicit
Public Type RowColumn
row As String
col As String
End Type
Public Function GetRowColumn(strRowColumn) As RowColumn
Dim lngCount As Long
Dim lngChar As String
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
GetRowColumn.col = Left(strRowColumn, lngCount - 1)
GetRowColumn.row = Right(strRowColumn, Len(strRowColumn) - lngCount + 1)
End Function
Sub GenerateAllReports()
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)
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
Set objExcelApp = New Excel.Application
Set objWorkbook = objExcelApp.Workbooks.Open(strPath & "\ReportTemplate\" & "Template.xls")
Set objWorksheet = objWorkbook.ActiveSheet
Set objCN = New ADODB.Connection
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & "\" & "GetColumnRow.mdb;Persist Security Info=False"
objCN.ConnectionString = strConn
objCN.Open
strSQL = "SELECT * FROM ReportQuery WHERE [A2] =" & Chr(34) & strCriteria & Chr(34)
Set objRS = New ADODB.Recordset
objRS.Open strSQL, objCN, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo ErrHandler
For Each objField In objRS.Fields
If IsNumeric(Right(objField.Name, 1)) Then
udtRowColumn = GetRowColumn(objField.Name)
objWorksheet.Cells(udtRowColumn.row, udtRowColumn.col) = objField.Value
End If
Next objField
objRS.Close
Set objRS = Nothing
objCN.Close
Set objCN = Nothing
strFileName = strPath & "\Reports\" & strCriteria & "_" & Format(Now(), "mmddyy") & ".xls"
objWorkbook.SaveAs strFileName
objWorkbook.Close
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcelApp = Nothing
Set objCN = Nothing
Set objRS = Nothing
Set objField = Nothing
Exit Sub
ErrHandler:
objWorkbook.Close
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcelApp = Nothing
Resume Next
End Sub
Option Compare Database
Option Explicit
Public Type RowColumn
row As String
col As String
End Type
Public Function GetRowColumn(strRowColumn) As RowColumn
Dim lngCount As Long
Dim lngChar As String
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
GetRowColumn.col = Left(strRowColumn, lngCount - 1)
GetRowColumn.row = Right(strRowColumn, Len(strRowColumn) - lngCount + 1)
End Function
Public Sub GenerateReport(ByVal strCriteria As String)
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
Set objExcelApp = New Excel.Application
Set objWorkbook = objExcelApp.Workbooks.Open(strPath & "\ReportTemplate\" & "Template.xls")
Set objWorksheet = objWorkbook.ActiveSheet
strSQL = "SELECT * FROM ReportQuery WHERE [A2] =" & Chr(34) & strCriteria & Chr(34)
Set ObjRS1 = New Recordset
ObjRS1.Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly, adCmdText
On Error GoTo ErrHandler
For Each objField In ObjRS1.Fields
If IsNumeric(Right(objField.Name, 1)) Then
udtRowColumn = GetRowColumn(objField.Name)
objWorksheet.Cells(udtRowColumn.row, udtRowColumn.col) = objField.Value
End If
Next objField
ObjRS1.Close
Set ObjRS1 = Nothing
strFileName = strPath & "\Reports\" & strCriteria & "_" & Format(Now(), "mmddyy") & ".xls"
objWorkbook.SaveAs strFileName
objWorkbook.Close
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcelApp = Nothing
Exit Sub
ErrHandler:
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
|