For those interested in Automating Access to move data from Access then
format those worksheets, EagleOne offers working procedures. Modify for your
use as needed.

Notice especially that "Excel" objects like Worksheets and Ranges are Dimmed
as "Objects" because of "Late Binding."

EagleOne owes most of this work/knowledge to Dev Ashish; Jim Rech; Dave Hargis
and others whom I believe are all MS MVP's.

All of the VBA code below goes into an Access VBA Module. The Excel procedures
are accomplished from Access.

************************************************** *******************************************
************************************************** *******************************************

Private Declare Function apiFindWindow Lib "user32" Alias _
"FindWindowA" (ByVal strClass As String, _
ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
"SendMessageA" (ByVal Hwnd As Long, ByVal Msg As Long, ByVal _
wParam As Long, lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
"SetForegroundWindow" (ByVal Hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias _
"ShowWindow" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias _
"IsIconic" (ByVal Hwnd As Long) As Long

Private Declare Sub sapiSleep Lib "kernel32" _
Alias "Sleep" (ByVal dwMilliseconds As Long)


'***************** Code Start ***************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

Function fIsAppRunning(ByVal strAppName As String, _
Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
Case "excel": strClassName = "XLMain"
Case "word": strClassName = "OpusApp"
Case "access": strClassName = "OMain"
Case "powerpoint95": strClassName = "PP7FrameClass"
Case "powerpoint97": strClassName = "PP97FrameClass"
Case "notepad": strClassName = "NOTEPAD"
Case "paintbrush": strClassName = "pbParent"
Case "wordpad": strClassName = "WordPadClass"
Case Else: strClassName = vbNullString
End Select

If strClassName = "" Then
lngH = apiFindWindow(vbNullString, strAppName)
Else
lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH < 0 Then
apiSendMessage lngH, WM_USER + 18, 0, 0
lngX = apiIsIconic(lngH)
If lngX < 0 Then
lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
End If
If fActivate Then
lngTmp = apiSetForegroundWindow(lngH)
End If
fIsAppRunning = True
End If
fIsAppRunning_Exit:
Exit Function
fIsAppRunning_Err:
fIsAppRunning = False
Resume fIsAppRunning_Exit
End Function
'******************** Code End ****************

Sub Export_Files_Macro()
'
'
' NOTE: If you wish to transfer tables as separate sheets in the
' same Excel workbook, just keep the receiving filename the same!!
' (See example below)
'
Dim myPath As String
Dim myDate As String
Dim myTime As String
Dim myFileName As String
Dim myPathFile As String

MsgBox ("This procedure may take up to XXX minutes" & Chr(10) _
& Chr(10) & " Press OK to continue .... ")
myPath = CurrentProject.Path & "\"
myDate = Replace(Date, "/", "-")
myTime = Format(Time(), "hhmm")
myFileName = "CHR_ALL_AAASITE_TBL " & myDate & " " & myTime & ".xls"
myPathFile = myPath & myFileName
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"CHR_ALL_AAASITE_TBL", myPath & myFileName, True
If Not Err.Number 0 Then
Call FormatXLSheets(myPathFile, myFileName)
End If
On Error GoTo 0
myFileName = "FNR_ALL_AAASITE_TBL " & myDate & " " & myTime & ".xls"
myPathFile = myPath & myFileName
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"FNR_ALL_AAASITE_TBL", myPath & myFileName, True
If Not Err.Number 0 Then
Call FormatXLSheets(myPathFile, myFileName)
End If
On Error GoTo 0
myFileName = "FSD_ALL_AAASITE_TBL " & myDate & " " & myTime & ".xls"
myPathFile = myPath & myFileName
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"FSD_ALL_AAASITE_TBL", myPath & myFileName, True
If Not Err.Number 0 Then
Call FormatXLSheets(myPathFile, myFileName)
End If

'************************************************* *********************
'
' NOTE: If you wish to transfer tables as separate sheets in the same
' Excel workbook, just keep the receiving filename the same!!
' (See example next below)
'
myFileName = "FBWT_ALL_Tables " & myDate & " " & myTime & ".xls"
myPathFile = myPath & myFileName
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"CHR_ALL_AAASITE_TBL", myPath & myFileName, True
On Error GoTo 0
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"FNR_ALL_AAASITE_TBL", myPath & myFileName, True
On Error GoTo 0
On Error Resume Next
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"FSD_ALL_AAASITE_TBL", myPath & myFileName, True
On Error GoTo 0
Call FormatXLSheets(myPathFile, myFileName)
MsgBox "Procedure Completed!"

If Err.Number 0 Then
MsgBox Error$
Stop
End If

End Sub

' Note: The two variables passed from Export_Files_Macro() above
Sub FormatXLSheets(myPathFile As String, myFileName As String)
'
'Essence of VBA Code Courtesy of Dev Ashish
' modified only for detail w/s procedures by
' EagleOne 6/13/2008
'
Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object
Dim Wks As Object
Dim myRange As Object
Dim myRange2 As Object
Dim myRowsToProcess As Long
Dim myColumnsToProcess As Long
Dim MaxRows As Long
Dim MaxColumns As Long

If fIsAppRunning("Excel") Then
Set objXL = GetObject(, "Excel.Application")
boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
boolXL = True
End If

With objXL.Application
'.Visible = True
.Visible = False
'Open the Workbook
.workbooks.Open myPathFile
'.ActiveWorkBook.RunAutoMacros xlAutoOpen
End With
Set objActiveWkb = objXL.Application.ActiveWorkBook
With objActiveWkb
Set Wks = Nothing
For Each Wks In .Worksheets
Wks.Activate
'Determine which Excel version Worksheet capacity
With Wks
MaxRows = .Rows.Count
MaxColumns = .Columns.Count
End With

'Accurately determine the usedrange for Autofilter
myRowsToProcess = Cells.Find(What:="*", After:=Wks.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
myColumnsToProcess = Cells.Find(What:="*", After:=Wks.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
myRowsToProcess = IIf(myRowsToProcess MaxRows, MaxRows, _
myRowsToProcess) myColumnsToProcess = _
IIf(myColumnsToProcess MaxColumns, MaxColumns, myColumnsToProcess)
Set myRange = Wks.Range(Cells(1, 1), _
Cells(myRowsToProcess, myColumnsToProcess))
Set myRange = Intersect(myRange, myRange.SpecialCells(xlCellTypeVisible))

myRange.AutoFilter

With Wks
'Format dollar columns
Columns("O:S").NumberFormat = _
"_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
'Select bold & "box" headers
Wks.Range(Cells(1, 1), Cells(1, myColumnsToProcess)).Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
'Filter and "color" questionable data items
myRange.AutoFilter Field:=5, Criteria1:="Not Found"
On Error Resume Next
Set myRange2 = Intersect(Wks.Range(Cells(2, 5), _
Cells(myRowsToProcess, 5)), _
myRange.SpecialCells(xlCellTypeVisible))
If Not Err.Number 0 Then
myRange2.Interior.ColorIndex = 6
myRange.AutoFilter Field:=5
End If
myRange.AutoFilter Field:=11, Criteria1:="Not Found"
On Error Resume Next
Set myRange2 = Intersect(Wks.Range(Cells(2, 11), _
Cells(myRowsToProcess, 11)), _
myRange.SpecialCells(xlCellTypeVisible))
If Not Err.Number 0 Then
myRange2.Interior.ColorIndex = 6
myRange.AutoFilter Field:=11
End If
myRange.AutoFilter Field:=14, Criteria1:="Inv"
On Error Resume Next
Set myRange2 = Intersect(Wks.Range(Cells(2, 14), _
Cells(myRowsToProcess, 14)), _
myRange.SpecialCells(xlCellTypeVisible))
If Not Err.Number 0 Then
myRange2.Interior.ColorIndex = 6
myRange.AutoFilter Field:=14
End If
'Sort & Filter
myRange.AutoFilter
If InStr(1, myFileName, "XXXXXXX", vbTextCompare) 0 Then
myRange.Sort Key1:=Range("M2"), Order1:=xlAscending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Key3:=Range("J2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortTextAsNumbers
Else
myRange.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("M2"), Order2:=xlAscending, _
Key3:=Range("J2"), Order3:=xlAscending, Header:= xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortTextAsNumbers
End If
myRange.AutoFilter
' Add TOtals & Underlines
Cells(Rows.Count, "O").End(xlUp)(3, 1).Formula = _
"=SUM(O2:O" & Cells(Rows.Count, 1).End(xlUp)(1, 1).Row & ")"
Cells(Rows.Count, "P").End(xlUp)(3, 1).Formula = _
"=SUM(P2:P" & Cells(Rows.Count, 1).End(xlUp)(1, 1).Row & ")"
Cells(Rows.Count, "Q").End(xlUp)(3, 1).Formula = _
"=SUM(Q2:Q" & Cells(Rows.Count, 1).End(xlUp)(1, 1).Row & ")"
Cells(Rows.Count, "R").End(xlUp)(3, 1).Formula = _
"=SUM(R2:R" & Cells(Rows.Count, 1).End(xlUp)(1, 1).Row & ")"
Cells(Rows.Count, "S").End(xlUp)(3, 1).Formula = _
"=SUM(S2:S" & Cells(Rows.Count, 1).End(xlUp)(1, 1).Row & ")"
Range(Cells(Rows.Count, "O").End(xlUp)(1, 1).Address & _
":" & Cells(Rows.Count, "S").End(xlUp)(1, 1).Address).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Cells.EntireColumn.AutoFit
Range("A1").Select
Next Wks
End With
On Error Resume Next
Worksheets(1).Activate
On Error Resume Next
objActiveWkb.Close savechanges:=True
On Error Resume Next
objXL.Application.Quit
Set objActiveWkb = Nothing: Set objXL = Nothing

End Sub

************************************************** **************************************

"Jim Rech" wrote:

If you don't activate each sheet then selecting A1 will not work (except on
the active sheet), so you might as well get rid of that line.

Prefix every range/cell reference with wks, or use With:

With wks
.Range("A1").Font.Bold= True
'etc
End With
or

wks.Range("A1").Font.Bold= True

You have a "With wks" but it looks like your formatting comes after it.
Move it inside it and of course use "." .