Question Export to Excel, Change Cell Colour

N

nick1408

Registered User.
Local time
Tomorrow, 06:21
Joined
Jun 16, 2016
Messages
77
Hi again fine peeps,

I am having my first real crack of VAB within Access to export and format Excel. My current code is as follows:

Code: 
 Sub ExportToExcel()
    Dim xlApp As Object
    Dim xlSheet As Object
    Dim oBook As Object
    Dim stamp As String
stamp = Month(Date) & Day(Date) & Year(Date)
  
         'check & close any instance of Excel running
        Set xlApp = CreateObject("Excel.Application")
        If Not (xlApp Is Nothing) Then
            xlApp.Application.DisplayAlerts = False
            xlApp.Workbooks.Close
            xlApp.Quit
            Set xlApp = Nothing
        End If
        
        Set xlApp = CreateObject("Excel.Application")
        
        xlApp.Visible = True
 Dim outputFileName As String
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyyMMdd") & ".xls"
DoCmd.OutputTo acOutputReport, ActiveReport, acFormatXLS, outputFileName, True
 xlApp.Workbooks.Open outputFileName, True, False
     Set xlApp = CreateObject("Excel.Application")
 xlApp.Visible = True
 Set XlBook = GetObject(outputFileName)
 XlBook.Windows(1).Visible = True
'xl.ActiveWindow.Zoom = 75
 'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
Set oBook = xlApp.Workbooks.Open(outputFileName)
 
'Then have some fun!
With xlsheet1
'    .range("A1") = "some data here"
'    .columns("A:A").HorizontalAlignment = xlRight
 '   .rows("1:1").Font.Bold = True
 
' Dim lRow As Long
 'lRow = Cells(Rows.Count, 1).End(xlUp).Row
 
  .Columns("A:A").EntireColumn.AutoFit
  .Columns("b:b").EntireColumn.AutoFit
  .Columns("c:c").EntireColumn.AutoFit
  .Columns("d:d").EntireColumn.ColumnWidth = 5
  .Columns("f:f").EntireColumn.AutoFit
  .Columns("g:g").EntireColumn.AutoFit
  .Columns("h:h").EntireColumn.AutoFit
  .Columns("i:i").EntireColumn.AutoFit
  .Columns("j:j").EntireColumn.AutoFit
  .Columns("k:k").EntireColumn.AutoFit
  .Columns("l:l").EntireColumn.AutoFit
.Columns("m:m").EntireColumn.AutoFit
  .Columns("n:n").EntireColumn.AutoFit
.Columns("o:o").EntireColumn.AutoFit
 .Columns("p:p").EntireColumn.AutoFit
 .Columns("q:q").EntireColumn.AutoFit
 .Columns("r:r").EntireColumn.AutoFit
 .range("P2").clearcontents
       .range("B1").clearcontents
     .Columns("E:E").WrapText = True
     
'     .cells("2:2").select.HorizontalAlignment = xlCenter
        
.range("A2:A65000").rows.AutoFit
        
'  ActiveWorkbook.Close SaveChanges:=True
        
End With
    oBook.Close True 'True = save changes
 Exit_Proc:
    Set xlApp = Nothing
    Set xlSheet = Nothing
End Sub
What I would like to do is add a bit at the bottom to change cell background colours depending on cell contents. I want a cell containing 'At Risk' to have bold text and a red background, 'Caution' to have an orange background with italic text and 'On Track' to have a green background.

I also have some (what I think are) easier questions. Two bits of my code aren't working as expected:

Code: 
  'check & close any instance of Excel running
        Set xlApp = CreateObject("Excel.Application")
        If Not (xlApp Is Nothing) Then
            xlApp.Application.DisplayAlerts = False
            xlApp.Workbooks.Close
            xlApp.Quit
            Set xlApp = Nothing
        End If
I expected this to close any open instances of Excel but it doesn't. Why is this?

This bit:
Code: 
 Set oBook = xlApp.Workbooks.Open(outputFileName)
 ...
    oBook.Close True 'True = save changes
I expect to close and save what I just created but it doesn't. What have I done wrong? What would be even better than this is if I could change the papersize to Tabloid, landscape and shrint to fit columns on one page then save as a .pdf. That would be the ultimate goal here but to save would be ideal.

One last thing -
Code: 
'     .cells("2:2").select.HorizontalAlignment = xlCenter
I wanted to centre on row 2 but it didn't work. Now commented out. What is the right way to centre text?

Thanks guys.
 
Last edited:
If you aren't planning to use conditional formatting, you could color the cells this way with a filter, assuming that the criteria are all in the same col. Change the Criteria to your actual criteria and the case to the values you are using and the color to your preference.

Code: 
'Filter only rows where cell value = 1 to speed up color formatting by only
                        'editing the filtered rows rather than all the rows in the range
                        '20160218
                        .autofiltermode = False
                        .Range(.Cells(1, 1), .Cells(lastrow, 1)).AutoFilter Field:=1, Criteria1:="1"
                        For Each cell In .Range(.Cells(2, 1), .Cells(lastrow, 1)).SpecialCells(xlCellTypeVisible)
                        'For Each cell In .Range(.Cells(2, 1), .Cells(lastrow, 1))
                            Select Case cell.Value
                                Case Is = 1: indexcolor = 3 'vbred
                                Case Is = 0: indexcolor = 1 'vbblack
                                Case Else: indexcolor = xlNone
                            End Select
Here is another way without filtering.
Code: 
'Conditional Formatting
                    For Each cell In .Range(.Cells(3, 3), .Cells(lastrow, 3))
                        Select Case cell.Value
                            Case Is = 5: indexcolor = 6 'stRGB = "rgb(255,255,0)"    Couldn't figure out how to put the rgb in variable
                            Case Is = 10: indexcolor = 45 'stRGB = "rgb(255,192,0)"  so used the closest ColorIndex based on the above
                            Case Is = 15: indexcolor = 43 'stRGB = "rgb(146,208,80)" mentioned website
                            Case Is = 20: indexcolor = 38 'stRGB = "rgb(255,204,255)"
                            Case Is = "ALL": indexcolor = 28 'stRGB = "rgb(0,255,255)"
                        End Select
                        .Range(.Cells(cell.row, 1), .Cells(cell.row, lastCol + 1)).Interior.ColorIndex = indexcolor
                    Next cell
I use this to center cols.
Code: 
.Columns(1).HorizontalAlignment = xlCenter
maybe try this for rows.
Code: 
.Rows(2).HorizontalAlignment = xlCenter
 
Thanks for taking the time to help.

Code: 
.rows(2).HorizontalAlignment = xlCenter

this throws a runtime error '1004' Unable to set the HorozontalAlignment property of the Range class

I'm also not sure where to put the colour filtering code. If I put it before the End With I get a compile error: End With without With and if I put it after the End With I get a compile error: Invalid or unqualified reference on the .autofiltermode =

Code: 
Sub ExportToExcel()
  On Error GoTo errorhandler
    Dim xlApp As Object
    Dim xlSheet As Object
    Dim oBook As Object
    Dim stamp As String
stamp = Month(Date) & Day(Date) & Year(Date)
  
         'check & close any instance of Excel running
        Set xlApp = CreateObject("Excel.Application")
        If Not (xlApp Is Nothing) Then
            xlApp.Application.DisplayAlerts = False
            xlApp.Workbooks.Close
            xlApp.Quit
            Set xlApp = Nothing
        End If
        
        Set xlApp = CreateObject("Excel.Application")
        
        xlApp.Visible = True
 Dim outputFileName As String
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyyMMdd") & ".xls"
DoCmd.OutputTo acOutputReport, ActiveReport, acFormatXLS, outputFileName, True
 xlApp.Workbooks.Open outputFileName, True, False
     Set xlApp = CreateObject("Excel.Application")
 xlApp.Visible = True
 Set XlBook = GetObject(outputFileName)
 XlBook.Windows(1).Visible = True
'xl.ActiveWindow.Zoom = 75
 'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
Set oBook = xlApp.Workbooks.Open(outputFileName)
 
'Then have some fun!
With xlsheet1
'    .range("A1") = "some data here"
'    .columns("A:A").HorizontalAlignment = xlRight
 '   .rows("1:1").Font.Bold = True
 
' Dim lRow As Long
 'lRow = Cells(Rows.Count, 1).End(xlUp).Row
 
  .Columns("A:A").EntireColumn.AutoFit
  .Columns("b:b").EntireColumn.AutoFit
  .Columns("c:c").EntireColumn.AutoFit
  .Columns("d:d").EntireColumn.ColumnWidth = 5
  .Columns("f:f").EntireColumn.AutoFit
  .Columns("g:g").EntireColumn.AutoFit
  .Columns("h:h").EntireColumn.AutoFit
  .Columns("i:i").EntireColumn.AutoFit
  .Columns("j:j").EntireColumn.AutoFit
  .Columns("k:k").EntireColumn.AutoFit
  .Columns("l:l").EntireColumn.AutoFit
.Columns("m:m").EntireColumn.AutoFit
  .Columns("n:n").EntireColumn.AutoFit
.Columns("o:o").EntireColumn.AutoFit
 .Columns("p:p").EntireColumn.AutoFit
 .Columns("q:q").EntireColumn.AutoFit
 .Columns("r:r").EntireColumn.AutoFit
 .Range("R2").clearcontents
       .Range("B1").clearcontents
     .Columns("E:E").WrapText = True
 End With
 'Filter only rows where cell value = 1 to speed up color formatting by only
                        'editing the filtered rows rather than all the rows in the range
                        '20160218
                        .autofiltermode = False
                        .Range(.Cells(1, 1), .Cells(lastrow, 1)).AutoFilter Field:=1, Criteria1:="1"
                        For Each cell In .Range(.Cells(2, 1), .Cells(lastrow, 1)).SpecialCells(xlCellTypeVisible)
                        'For Each cell In .Range(.Cells(2, 1), .Cells(lastrow, 1))
                            Select Case cell.Value
                                Case Is = 1: indexcolor = 3 'vbred
                                Case Is = 0: indexcolor = 1 'vbblack
                                Case Else: indexcolor = xlNone
                            End Select
     
     .rows(2).HorizontalAlignment = xlCenter
        
.Range("A2:A65000").rows.AutoFit
        
'  ActiveWorkbook.Close SaveChanges:=True
        
 
   oBook.Close True 'True = save changes
 Exit_Proc:
    Set xlApp = Nothing
    Set xlSheet = Nothing
    Exit Sub
 errorhandler:
    MsgBox ("There is an error in the report." & vbNewLine & "Check Date Milestone Met column." & vbNewLine & "Ensure one of steps, 1, 4, 11, 12, 13 15, 21, 22, 24, 28, 35,36 or 38 are selected." & vbNewLine & "Ensure MS Excel is not already open when trying to export" & vbNewLine & "If error still persists after these checks contact administrator")
End Sub
 
I'll see if I can look into this tomorrow. What version are you using? I have Office 2013
 
Got a little busy at work. If you have a sample file, I could try to test it out in the evening during the week.
 
You must log in or register to reply here.

Similar threads

B
  • Question Question
export and transpose problem
Replies
8
Views
357
Pat Hartman
P
Gasman
Solved Open Excel workbook, but have WorkBook_Open code run
Replies
19
Views
368
Gasman
Gasman
Gasman
Solved Cannot see the wood for the trees :(
Replies
15
Views
543
Gasman
Gasman
zelarra821
Solved Export to Excel and leave the workbook open
Replies
5
Views
639
zelarra821
zelarra821
R
Updating Excel spreadsheet from within the Access
Replies
8
Views
1,358
CJ_London
C

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom