Prev: Filedialog err 438 Object doesn't support this property or method
Next: DoCmd.RunCommand acCmdFind
From: geoderek on 13 Dec 2006 15:30
good stuff thanks.


Klatuu wrote:
> 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 xlSheet.Range("A2", "A" & Trim(str(lngItmCount + 2)))
> cell.Font.Size = 10
> cell.Font.Name = "Arial"
> cell.Font.Bold = True
> cell.Interior.Color = conLightGray
> cell.HorizontalAlignment = xlHAlignLeft
> cell.WrapText = False
> Next
> End With
>
> 'Merge the ITM Cells
> For intX = 2 To lngItmCount + 2
> strLeftRange = "A" & Trim(str(intX)) & ":B" & Trim(str(intX))
> xlSheet.Range(strLeftRange).MergeCells = True
> Next intX
>
> 'Size the Blank Row
> xlSheet.Rows(lngItmCount + 3).RowHeight = 30
>
> 'Format Header Area and put in formulas
> With xlSheet
> For intX = 2 To lngItmCount + 1
> strLeftRange = "C" & Trim(str(intX))
> strRightRange = "S" & Trim(str(intX))
> For Each cell In xlSheet.Range(strLeftRange, strRightRange)
> cell.Font.Size = 10
> cell.Font.Name = "Arial"
> cell.Font.Bold = True
> cell.Interior.Color = conLightBlue
> cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
> Next
> Next intX
> 'Do The Grand Total Row
> strLeftRange = "C" & Trim(str(intX))
> strRightRange = "S" & Trim(str(intX))
> For Each cell In xlSheet.Range(strLeftRange, strRightRange)
> cell.Font.Size = 10
> cell.Font.Name = "Arial"
> cell.Font.Bold = True
> cell.Interior.Color = conLightYellow
> cell.Formula = "= Grand"
> cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
> Next
> End With
>
> 'Put Borders around the Header Area
> With xlSheet.Range("A1", "S" & Trim(str(lngItmCount + 2)))
> .Borders(xlTop).LineStyle = xlContinuous
> .Borders(xlTop).Weight = xlThin
> .Borders(xlBottom).LineStyle = xlContinuous
> .Borders(xlBottom).Weight = xlThin
> .Borders(xlLeft).LineStyle = xlContinuous
> .Borders(xlLeft).Weight = xlThin
> .Borders(xlRight).LineStyle = xlContinuous
> .Borders(xlRight).Weight = xlThin
> End With
>
> 'Add Total to ITM Names
> For intX = 2 To lngItmCount + 1
> xlSheet.Cells(intX, 1) = "Grand Total " & xlSheet.Cells(intX, 1)
> Next intX
> xlSheet.Cells(intX, 1) = "Grand Total " & _
> Me.cboResource & " HOURS"
>
> 'Copy the Header Row to the top of the Data Area
> xlSheet.Range("A1:S1").Copy _
> Destination:=xlSheet.Range("A" & Trim(str(intX + 2)))
>
> 'Load the Data
> Me.txtStatus = "Loading Detail Data"
> Me.Repaint
>
> Set qdf = CurrentDb.QueryDefs("qselSCCBrpt")
> qdf.Parameters(0) = Me.cboResource
> qdf.Parameters(1) = Me.cboPeriod
> Set rstSCCB = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
> xlSheet.Cells(intX + 3, 1).CopyFromRecordset rstSCCB
> lngDetailCount = rstSCCB.RecordCount
> rstSCCB.Close
> Set rstSCCB = Nothing
> Set qdf = Nothing
>
> 'Put in the SubTotals
> Me.txtStatus = "Creating Subtotals"
> Me.Repaint
>
> lngFirstDataRow = intX + 3
> lngLastDataRow = lngFirstDataRow + lngItmCount + lngDetailCount
> With xlSheet
> .Range(.Cells(lngFirstDataRow - 1, 1), _
> .Cells(lngLastDataRow, 19)).Subtotal groupBy:=1,
> Function:=xlSum, _
> totalList:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
> 16, 17, 18, 19)
> End With
>
> 'Create Formulas and range names
> For lngRowCount = lngFirstDataRow To lngLastDataRow
> lngTotalPos = InStr(xlSheet.Cells(lngRowCount, 1), "Total")
> If lngTotalPos = 0 Then 'Column S needs to be light yellow if not a
> total row
> xlSheet.Cells(lngRowCount, 5).Interior.Color = conLightYellow
> xlSheet.Cells(lngRowCount, 6).Interior.Color = conLightYellow
> Else
> strCurrItm = Left(xlSheet.Cells(lngRowCount, 1), lngTotalPos - 2)
> With xlSheet
> .Range("C" & Trim(str(lngRowCount)) & ":S" & _
> Trim(str(lngRowCount))).Name = strCurrItm
> .Range("A" & Trim(str(lngRowCount)) & ":S" & _
> Trim(str(lngRowCount))).Interior.Color = conLightGray
> End With
> End If
> Next lngRowCount
>
> 'Clear the subtotals
> xlSheet.Range("A:S").Copy
> xlSheet.Range("A:S").PasteSpecial (xlPasteValues)
> xlSheet.Range("A:S").RemoveSubtotal
> xlSheet.Cells(1, 1).Select 'Removes the selection
>
> 'Set the Margins, Headers and Footers
> Me.txtStatus = "Formating Worksheet"
> Me.Repaint
>
> strPrintArea = "A1:S" & Trim(str(lngLastDataRow))
> strTitleRows = 1 & ":" & Trim(str(lngItmCount + 3))
> With xlSheet.PageSetup
> .Orientation = xlLandscape
> .Zoom = False
> .FitToPagesTall = False
> .FitToPagesWide = 1
> .CenterHeader = Me.txtCurrYear & " " & Me.cboResource _
> & " Hours " & strMonth & " YTD"
> .CenterFooter = "&F" & " " & "&D"
> .RightFooter = "&R Page &P of &N"
> .LeftMargin = xlApp.InchesToPoints(0)
> .RightMargin = xlApp.InchesToPoints(0)
> .TopMargin = xlApp.InchesToPoints(0.5)
> .BottomMargin = xlApp.InchesToPoints(0.5)
> .HeaderMargin = xlApp.InchesToPoints(0.25)
> .FooterMargin = xlApp.InchesToPoints(0.25)
> .PrintArea = strPrintArea
> .PrintTitleRows = xlSheet.Rows(strTitleRows).Address
> End With
>
> 'Format the Data Area
> With xlSheet
> strLeftRange = "A" & Trim(str(lngFirstDataRow))
> strRightRange = "S" & Trim(str(lngLastDataRow))
> For Each cell In xlSheet.Range(strLeftRange, strRightRange)
> cell.Font.Size = 10
> cell.Font.Name = "Arial"
> cell.Font.Bold = True
> cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
> Next
> End With
>
> 'Put Borders around the Data Area
> With xlSheet.Range(strLeftRange, strRightRange)
> .Borders(xlTop).LineStyle = xlContinuous
> .Borders(xlTop).Weight = xlThin
> .Borders(xlBottom).LineStyle = xlContinuous
> .Borders(xlBottom).Weight = xlThin
> .Borders(xlLeft).LineStyle = xlContinuous
> .Borders(xlLeft).Weight = xlThin
> .Borders(xlRight).LineStyle = xlContinuous
> .Borders(xlRight).Weight = xlThin
> End With
>
> 'Spreadsheet is complete - Save it
>
> 'Set up default path and file
> strCurrYear = Me.txtCurrYear
> strCurrMonth = Me.cboPeriod.Column(1)
> strDefaultDir = "\\rsltx1-bm01\busmgmt\Vought " & strCurrYear & "\" &
> strCurrYear _
> & " Actuals\" & strCurrMonth & "\"
> strDefaultFileName = Me.cboPeriod.Column(1) & _
> IIf([Forms]![frmsccbrpt]![cboResource] = "SEL", _
> " SCCB Report", " " & Me.cboResource & " Performance Report") &
> ".xls"
> 'Set filter to show only Excel spreadsheets
> strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)")
> 'Flags Hides the Read Only Check and Only allow existing files
> lngFlags = ahtOFN_HIDEREADONLY Or ahtOFN_OVERWRITEPROMPT
> 'Call the Open File Dialog
> varGetFileName = ahtCommonFileOpenSave( _
> OpenFile:=False, _
> InitialDir:=strDefaultDir, _
> Filter:=strFilter, _
> Filename:=strDefaultFileName, _
> Flags:=lngFlags, _
> DialogTitle:="Save Report")
> If varGetFileName <> "" Then
> xlBook.SaveAs Filename:=varGetFileName
> Select Case strOutPut
> Case "Print"
> blnStopXl = True
> xlSheet.PrintOut Copies:=1, Collate:=True
> Case "PreView"
> blnStopXl = True
> xlApp.DisplayAlerts = True
> xlApp.Interactive = True
> xlApp.ScreenUpdating = True
> xlApp.Visible = True
> xlApp.WindowState = xlMaximized
> xlSheet.PrintPreview
> xlApp.Visible = False
> Case "XL"
> blnStopXl = False
> xlApp.DisplayAlerts = True
> xlApp.Interactive = True
> xlApp.ScreenUpdating = True
> xlApp.WindowState = xlMaximized
> xlApp.Visible = True
> End Select
> End If
> 'Time to Go
> Build_XL_Report_Exit:
> Me.txtStatus.Visible = False
> Me.Repaint
>
> If blnStopXl Then
> xlBook.Close
> If blnExcelWasNotRunning = True Then
> xlApp.Quit
> Else
> xlApp.DisplayAlerts = True
> xlApp.Interactive = True
> xlApp.ScreenUpdating = True
> End If
> Set xlSheet = Nothing
> Set xlBook = Nothing
> Set xlApp = Nothing
> End If
> DoCmd.Hourglass (False)
>
> Exit Sub
>
> Build_XL_Report_ERR:
> MsgBox (Err.Number & " - " & Err.Description)
> blnStopXl = True
> GoTo Build_XL_Report_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
> >
> >

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