Prev: Filedialog err 438 Object doesn't support this property or method
Next: DoCmd.RunCommand acCmdFind
From: andreas.strzodka on 10 Nov 2006 15:05
Hello,

I am exporting a spreadsheet from an Access database and I want to
format the excel file. Thus, I have written to pieces of VBA code, one
in Access, one in Excel. Does anybody have any ideas on how to combine
them. I have looked up several solutions, yet have not found a workable
one.

The Access Code:
Sub Request_Export_Click()
Dim datestr As String

datestr = Me.File_Date

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
In", "H:\HS Details " & datestr & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
Out", "H:\HS Details " & datestr & ".xls"

End Sub

The Excel Code:
Sub format_worksheet()

Columns("a:a").ColumnWidth = 7.5
Columns("b:ao").ColumnWidth = 15

Cells.Select
With Selection
.Font.Name = "Arial"
.Font.Size = 8
End With

Range("a1:ao600").Select
With Selection
.WrapText = True
.ShrinkToFit = True
End With

Range("a1:ao1").Select
With Selection
.HorizontalAlignment = xlCenter
End With

End Sub

Thanks,

Andreas

From: Klatuu on 10 Nov 2006 16:44
You will need to do this in Access. You can manipulate the Excel object
model from Access, but the syntax will be a little different that if you are
actually in Excel. The code below is much more than you need, but you can
use it to copy the pieces you do need into your own code. The important part
when using automation between Access and Excel is how you open and close a
reference to Excel and how you refer to the Excel objects. If not done
correctly, it can create problems. So, enjoy (and post back if you need help
understanding any of this)

Sub Build_XL_Report(strOutPut As String)
Const conLightGray As Long = 12632256
Const conLightBlue As Long = 16777164
Const conLightYellow As Long = 10092543

Dim xlApp As Object 'Application Object
Dim xlBook As Object 'Workbook Object
Dim xlSheet As Object 'Worksheet Object
Dim varGetFileName As Variant 'File Name with Full Path
Dim rstSCCB As Recordset 'Recordset to load data from
Dim rstItms As Recordset 'Recordset to load ITM Name in Header
Dim qdf As QueryDef 'Query def to load data
Dim lngItmCount As Long 'Number of ITMs in the RecordSet
Dim lngDetailCount As Long 'Number of Detail Data rows in the recordset
Dim intX As Integer 'Loop Counter
Dim strMonth As String 'Used to create a Short month name ie
January to Jan
Dim strCurrItm As String 'Hold the ITM Name to format Total cell
Dim lngRowCount As Long 'A loop counter that gives the current row
reference
Dim lngTotalPos As Long 'Used to format ITM Total cells
Dim strPrintArea As String 'Defines the print area for the sheet
Dim strTitleRows As String 'Defines the rows to print at the top of
each page
Dim strLeftRange As String 'Used to format range references
Dim strRightRange As String 'Used to format range references
Dim lngFirstDataRow As Long 'The first row with detail data
Dim lngLastDataRow As Long 'The last row with detail data
Dim blnExcelWasNotRunning As Boolean
Dim strDefaultDir 'Where to save spreadsheet
Dim strDefaultFileName 'Name to Save as
Dim lngFlags As Long 'Flags for common dialog
Dim strFilter As String 'File Display for Common Dialog
Dim strCurrMonth As String 'To create directory name for save
Dim strCurrYear As String 'To create directory name for save
Dim blnStopXl As Boolean 'Leave Open for Spreadsheet Version

On Error GoTo Build_XL_Report_ERR

DoCmd.Hourglass (True)
Me.txtStatus = "Updating Queries"
Me.txtStatus.Visible = True
'Fix the Queries so you dont have to be hand each month
Call FixSql("qselsccbactual", "actual_res_export")
Call FixSql("qselsccbactualtot", "actual_res_export")
Me.txtStatus = "Getting ITM Data"
Me.Repaint

'Set up the necessary objcts
On Error Resume Next ' Defer error trapping.
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
blnExcelWasNotRunning = True
Set xlApp = CreateObject("excel.application")
Else
DetectExcel
End If
Err.Clear ' Clear Err object in case error occurred.
On Error GoTo Build_XL_Report_ERR
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False
Set xlBook = xlApp.Workbooks.Add

Me.txtStatus = "Building Workbook"
Me.Repaint

'Remove excess worksheets
Do While xlBook.Worksheets.Count > 1
xlApp.Worksheets(xlApp.Worksheets.Count).Delete
Loop
Set xlSheet = xlBook.ActiveSheet

'Build The Spreadsheet
'Build The Headers
Me.txtStatus = "Creating Headers"
Me.Repaint

strMonth = Left(Me.cboPeriod.Column(1), 3)
xlSheet.Name = Me.cboResource & " Hours " & strMonth & " YTD"
With xlSheet
.Cells(1, 1) = "ITM"
.Cells(1, 2) = Me.txtCurrYear & _
" Activity # Description"
.Cells(1, 3) = "Budget " & Me.txtCurrYear
.Cells(1, 4).Value = Me.txtCurrYear & " YTD Budget"
.Cells(1, 5) = "Actuals YTD"
.Cells(1, 6) = "Variance YTD"
.Cells(1, 7) = "TO GO"
.Cells(1, 8) = IIf(Me.cboPeriod >= 1, "JAN ACT", "JAN ETC")
.Cells(1, 9) = IIf(Me.cboPeriod >= 2, "FEB ACT", "FEB ETC")
.Cells(1, 10) = IIf(Me.cboPeriod >= 3, "MAR ACT", "MAR ETC")
.Cells(1, 11) = IIf(Me.cboPeriod >= 4, "APR ACT", "APR ETC")
.Cells(1, 12) = IIf(Me.cboPeriod >= 5, "MAY ACT", "MAY ETC")
.Cells(1, 13) = IIf(Me.cboPeriod >= 6, "JUN ACT", "JUN ETC")
.Cells(1, 14) = IIf(Me.cboPeriod >= 7, "JUL ACT", "JUL ETC")
.Cells(1, 15) = IIf(Me.cboPeriod >= 8, "AUG ACT", "AUG ETC")
.Cells(1, 16) = IIf(Me.cboPeriod >= 9, "SEP ACT", "SEP ETC")
.Cells(1, 17) = IIf(Me.cboPeriod >= 10, "OCT ACT", "OCT ETC")
.Cells(1, 18) = IIf(Me.cboPeriod >= 11, "NOV ACT", "NOV ETC")
.Cells(1, 19) = IIf(Me.cboPeriod >= 12, "DEC ACT", "DEC ETC")
End With
'Format Row 1
With xlSheet
For Each cell In xlSheet.Range("A1", "S1")
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.Interior.Color = conLightGray
cell.HorizontalAlignment = xlHAlignCenter
cell.WrapText = True
Next
.Cells(1, 2).HorizontalAlignment = xlHAlignLeft
.Columns("A").ColumnWidth = 9
.Columns("B").ColumnWidth = 39
.Columns("C:S").ColumnWidth = 9
.Rows(1).RowHeight = 25.5
End With

'Set Up Recordset for ITM Header data
Me.txtStatus = "Loading ITM Data"
Me.Repaint

Set qdf = CurrentDb.QueryDefs("qselSCCBhdr")
qdf.Parameters(0) = Me.cboResource
qdf.Parameters(1) = Me.cboPeriod
Set rstItms = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
'Be sure there are records to process
rstItms.MoveLast
rstItms.MoveFirst
lngItmCount = rstItms.RecordCount
If lngItmCount = 0 Then
MsgBox "No Data Found For This Report", vbInformation + vbOKOnly,
"Data Error"
GoTo Build_XL_Report_Exit
End If

'Load Header Data
xlSheet.Cells(2, 1).CopyFromRecordset rstItms
rstItms.Close
Set rstItms = Nothing
Set qdf = Nothing

'Format the ITM Name Cells
Me.txtStatus = "Formatting Headers"
Me.Repaint

With xlSheet
For Each cell In xl
From: BruceS bruce at on 10 Nov 2006 16:46
Andreas,

Had a similar need just last week. You can open the spreadsheet and make
the format changes all from VBA. Here is my code, which works in A2K. Maybe
you can take something from it.

Bruce

Sub SetSpreadsheetHeadings( _
forFilePath As String, _
Optional tabName As String)

On Error GoTo Proc_Err
'
' Sets headings for new spreadsheet.
'
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim bolLeaveOpen As Boolean

If IsMissing(tabName) Then tabName = ""

'If Excel is already open, use that instance
bolLeaveOpen = True

'Attempting to use something that is not available
' will generate an error.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Err.Clear

On Error GoTo Proc_Err

'If xlApp is defined, then we already have a conversation open
If TypeName(xlApp) = "Nothing" Then
bolLeaveOpen = False
'Excel was not open -- create a new instance
Set xlApp = CreateObject("Excel.Application")
End If

'Keep any open workbooks from running any macros while I'm using it.
xlApp.EnableEvents = False

'Open workbook just created.
Set wb = xlApp.Workbooks.Open(forFilePath)

'Keep the workbook from running macros while I use it.
xlApp.EnableEvents = False

'Rename tab.
wb.Worksheets("ExportTemp").Select
If tabName > "" Then
wb.Worksheets("ExportTemp").Name = tabName
Else
tabName = "ExportTemp"
End If

'Select headings row and format.
wb.Worksheets(tabName).Rows("1:1").Select
With xlApp.Selection
.Font.FontStyle = "Bold"
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
With .Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End With

'Set all columns to best width.
wb.Worksheets(tabName).Cells.Select
xlApp.Selection.Columns.AutoFit

'Deselect heading row by selecting single cell.
wb.Worksheets(tabName).Range("A2").Select

'Save changes, then be sure they are saved before continuing.
wb.Save
DoEvents

'Close this specific workbook.
wb.Close False

'Turn macros back on for any workbooks still open.
xlApp.EnableEvents = True

Proc_Exit:
On Error Resume Next

If TypeName(xlApp) <> "Nothing" Then
If Not bolLeaveOpen Then xlApp.Quit
End If

Set wb = Nothing
Set xlApp = Nothing

Err.Clear
Exit Sub

Proc_Err:
MsgBox "Error editing spreadsheet:" & vbCr & vbCr & _
"Error Code: " & Err.Number & vbCr & _
Err.Description, vbOKCritical, "Error!"
Err.Clear

Resume Proc_Exit

End Sub


"andreas.strzodka(a)ny.frb.org" wrote:

> Hello,
>
> I am exporting a spreadsheet from an Access database and I want to
> format the excel file. Thus, I have written to pieces of VBA code, one
> in Access, one in Excel. Does anybody have any ideas on how to combine
> them. I have looked up several solutions, yet have not found a workable
> one.
>
> The Access Code:
> Sub Request_Export_Click()
> Dim datestr As String
>
> datestr = Me.File_Date
>
> DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
> In", "H:\HS Details " & datestr & ".xls"
> DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
> Out", "H:\HS Details " & datestr & ".xls"
>
> End Sub
>
> The Excel Code:
> Sub format_worksheet()
>
> Columns("a:a").ColumnWidth = 7.5
> Columns("b:ao").ColumnWidth = 15
>
> Cells.Select
> With Selection
> .Font.Name = "Arial"
> .Font.Size = 8
> End With
>
> Range("a1:ao600").Select
> With Selection
> .WrapText = True
> .ShrinkToFit = True
> End With
>
> Range("a1:ao1").Select
> With Selection
> .HorizontalAlignment = xlCenter
> End With
>
> End Sub
>
> Thanks,
>
> Andreas
>
>
From: Klatuu on 10 Nov 2006 17:02
Nice code, Bruce.
I would make one suggestion. The Selection object in Automation can get
squirly on you. It is really better to use the Range object. It seems to be
more stable.

"BruceS" wrote:

> Andreas,
>
> Had a similar need just last week. You can open the spreadsheet and make
> the format changes all from VBA. Here is my code, which works in A2K. Maybe
> you can take something from it.
>
> Bruce
>
> Sub SetSpreadsheetHeadings( _
> forFilePath As String, _
> Optional tabName As String)
>
> On Error GoTo Proc_Err
> '
> ' Sets headings for new spreadsheet.
> '
> Dim xlApp As Excel.Application
> Dim wb As Excel.Workbook
> Dim bolLeaveOpen As Boolean
>
> If IsMissing(tabName) Then tabName = ""
>
> 'If Excel is already open, use that instance
> bolLeaveOpen = True
>
> 'Attempting to use something that is not available
> ' will generate an error.
> On Error Resume Next
> Set xlApp = GetObject(, "Excel.Application")
> Err.Clear
>
> On Error GoTo Proc_Err
>
> 'If xlApp is defined, then we already have a conversation open
> If TypeName(xlApp) = "Nothing" Then
> bolLeaveOpen = False
> 'Excel was not open -- create a new instance
> Set xlApp = CreateObject("Excel.Application")
> End If
>
> 'Keep any open workbooks from running any macros while I'm using it.
> xlApp.EnableEvents = False
>
> 'Open workbook just created.
> Set wb = xlApp.Workbooks.Open(forFilePath)
>
> 'Keep the workbook from running macros while I use it.
> xlApp.EnableEvents = False
>
> 'Rename tab.
> wb.Worksheets("ExportTemp").Select
> If tabName > "" Then
> wb.Worksheets("ExportTemp").Name = tabName
> Else
> tabName = "ExportTemp"
> End If
>
> 'Select headings row and format.
> wb.Worksheets(tabName).Rows("1:1").Select
> With xlApp.Selection
> .Font.FontStyle = "Bold"
> .Borders(xlDiagonalDown).LineStyle = xlNone
> .Borders(xlDiagonalUp).LineStyle = xlNone
> .Borders(xlEdgeLeft).LineStyle = xlNone
> .Borders(xlEdgeTop).LineStyle = xlNone
> With .Borders(xlEdgeBottom)
> .LineStyle = xlContinuous
> .Weight = xlThin
> .ColorIndex = xlAutomatic
> End With
> .Borders(xlEdgeRight).LineStyle = xlNone
> .Borders(xlInsideVertical).LineStyle = xlNone
> With .Interior
> .ColorIndex = 15
> .Pattern = xlSolid
> .PatternColorIndex = xlAutomatic
> End With
> End With
>
> 'Set all columns to best width.
> wb.Worksheets(tabName).Cells.Select
> xlApp.Selection.Columns.AutoFit
>
> 'Deselect heading row by selecting single cell.
> wb.Worksheets(tabName).Range("A2").Select
>
> 'Save changes, then be sure they are saved before continuing.
> wb.Save
> DoEvents
>
> 'Close this specific workbook.
> wb.Close False
>
> 'Turn macros back on for any workbooks still open.
> xlApp.EnableEvents = True
>
> Proc_Exit:
> On Error Resume Next
>
> If TypeName(xlApp) <> "Nothing" Then
> If Not bolLeaveOpen Then xlApp.Quit
> End If
>
> Set wb = Nothing
> Set xlApp = Nothing
>
> Err.Clear
> Exit Sub
>
> Proc_Err:
> MsgBox "Error editing spreadsheet:" & vbCr & vbCr & _
> "Error Code: " & Err.Number & vbCr & _
> Err.Description, vbOKCritical, "Error!"
> Err.Clear
>
> Resume Proc_Exit
>
> End Sub
>
>
> "andreas.strzodka(a)ny.frb.org" wrote:
>
> > Hello,
> >
> > I am exporting a spreadsheet from an Access database and I want to
> > format the excel file. Thus, I have written to pieces of VBA code, one
> > in Access, one in Excel. Does anybody have any ideas on how to combine
> > them. I have looked up several solutions, yet have not found a workable
> > one.
> >
> > The Access Code:
> > Sub Request_Export_Click()
> > Dim datestr As String
> >
> > datestr = Me.File_Date
> >
> > DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
> > In", "H:\HS Details " & datestr & ".xls"
> > DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ACCOUNTS
> > Out", "H:\HS Details " & datestr & ".xls"
> >
> > End Sub
> >
> > The Excel Code:
> > Sub format_worksheet()
> >
> > Columns("a:a").ColumnWidth = 7.5
> > Columns("b:ao").ColumnWidth = 15
> >
> > Cells.Select
> > With Selection
> > .Font.Name = "Arial"
> > .Font.Size = 8
> > End With
> >
> > Range("a1:ao600").Select
> > With Selection
> > .WrapText = True
> > .ShrinkToFit = True
> > End With
> >
> > Range("a1:ao1").Select
> > With Selection
> > .HorizontalAlignment = xlCenter
> > End With
> >
> > End Sub
> >
> > Thanks,
> >
> > Andreas
> >
> >
From: RoyVidar on 10 Nov 2006 16:59
"Klatuu" <Klatuu(a)discussions.microsoft.com> wrote in message
<1042F6C8-8ECD-4446-8143-79D128205904(a)microsoft.com>:

Very nice code, Klatuu, I'm sure you have a declaration section
where you declare all the xlConstants, don't you? (probably also
contains declaration of "cell", too?)

Else there'd probably be some challenges going late bound.

--
Roy-Vidar


 |  Next  |  Last
Pages: 1 2 3 4 5
Prev: Filedialog err 438 Object doesn't support this property or method
Next: DoCmd.RunCommand acCmdFind