Results 1 to 3 of 3
  1. #1
    nick1408 is offline Novice
    Windows 10 Access 2013 64bit
    Join Date
    Jul 2016
    Posts
    1

    Export to Excel, Change Cell Colour

    Hi again guys and girls,



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

    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
    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?

    So far I have tried the following alternitives:
    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
    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'm 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.

    I have tried alternatives for xlcenter as well:
    Code:
    .rows(2).HorizontalAlignment = xlCenter
    this throws a runtime error '1004' Unable to set the HorozontalAlignment property of the Range class

    I'm using Office 2013

    Thanks for the help on a weekend.

  2. #2
    Join Date
    Apr 2010
    Location
    Steamboat Springs
    Posts
    2,529

  3. #3
    Micron is offline Virtually Inert Person
    Windows 7 32bit Access 2007
    Join Date
    Jun 2014
    Location
    Ontario, Canada
    Posts
    12,737
    The more we hear silence, the more we begin to think about our value in this universe.
    Paraphrase of Professor Brian Cox.

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 1
    Last Post: 03-11-2016, 01:27 PM
  2. export to excel starting from Cell A2
    By ice051505 in forum Programming
    Replies: 7
    Last Post: 04-25-2013, 03:15 PM
  3. Replies: 4
    Last Post: 09-19-2012, 11:49 AM
  4. Changing the colour of a cell?
    By WayneSteenkamp in forum Access
    Replies: 3
    Last Post: 03-08-2012, 10:12 AM
  5. Export a value to specific Excel cell
    By gg80 in forum Import/Export Data
    Replies: 5
    Last Post: 07-23-2010, 01:58 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums