Apply Table Formatting in Excel Export

[pastelrain]

Hi,
I've been scouring the internet trying to find a way to make this work. I want to apply excel table formatting to an export from Access using VBA. Below is what I currently have. Can anyone help?? :banghead:

Private Sub SandorFormatting_Click()
Dim Filename As String
Dim month1 As String
Dim year1 As Integer

Dim startTime As Date
startTime = Now


Dim strDirectoryPath As String
strDirectoryPath = "U:\Desktop"

Filename = strDirectoryPath & "\" & "QI_GAP_REPORT_FORMATTING" & Format$(Now(), "mm-dd-yyyy") & ".xls"
DoCmd.OpenQuery "QI_GAP_REPORT_FORMATTING"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QI_GAP_REPORT_FORMATTING", Filename, False, "Summary"
DoCmd.Close acQuery, "QI_GAP_REPORT_FORMATTING"

'///****Format excel workbook****////
' Late binding to avoid reference:
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Workbook
Dim xlWS As Object 'Worksheet
Dim GetBook As String


' Create the instance of Excel that we will use to open the temp book
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(Filename)
Set xlWS = xlWB.Worksheets("Summary")


' Format temp sheet
' ***************************************************************************
xlApp.Range("A1").Select

Const xlLandscape As Long = 2
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContext As Integer = -5002
Const xlDown As Integer = -4121
Const xlContinuous As Integer = 1
Const xlThin As Integer = 2

With xlWS
With .UsedRange
.borders.LineStyle = xlContinuous
.borders.ColorIndex = 0
.borders.TintAndShade = 0
.borders.Weight = xlThin
End With


'format header 90 degree
With .Range("i1:ae1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.UsedRange.Rows.RowHeight = 15
.UsedRange.Columns.AutoFit



'Disclaimer

Call .Range("A1:A10").EntireRow.insert
.Cells(1, 1).Value = "HEDIS 2017"
.Cells(2, 1).Value = "Part-C claims through May 31, 2016"
.Cells(3, 1).Value = "Part-D HRM and Part-D MA claims processed through June 16, 2016"
.Cells(4, 1).Value = "Part-D SUPD processed through June 16, 2016"
.Cells(5, 1).Value = "Part-D SUPD processed through June 16, 2016"
'.Cells(6, 1).Value = "Annual Flu Vaccine Service Dates Between July 1, 2015 to January 20, 2016"
.Cells(7, 1).Value = "The information contained in this report is intended only for the person or entity to which it is addressed and may contain CONFIDENTIAL material. If you receive this material/information in error, please contact your Account Executive and destroy the material/information."
.Cells(8, 1).Value = "Disclaimer - The information contained in this report is not a medical report, nor is it intended to be a complete record of a patient’s health information."
.Cells(9, 1).Value = "Certain information may have been intentionally excluded and the report may also contain errors. Physicians must use their professional judgment to verify this information and should not exclusively rely on this information to treat their patients."
.Cells(10, 1).Value = "Users of this report must take appropriate steps to safeguard the information contained within this report."

'Format
.Range("A1:A7").Font.Bold = True
.Range("A8:A10").Font.Italic = True

.Range("a11").EntireRow.AutoFit

With .UsedRange.Font
.Name = "Arial"
.Size = 9
End With
With .Range("A11:AE11")
.Font.Bold = True
.borders.LineStyle = xlContinuous
.borders.ColorIndex = 0
.borders.TintAndShade = 0
.borders.Weight = xlThin
End With

End With

With xlWS.PageSetup
.PrintHeadings = False
.PrintGridlines = False
.Orientation = xlLandscape
.Draft = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False ' this used to be 0 on previous printers but False works on the new Xerox
.PrintTitleRows = "$1:$11"
End With
'DOESN'T WORK
With xlWS
.ListObjects.Add(xlSrcRange, .Range("A12").CurrentRegion, , xlYes).Name = _
"Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight9"
End With
xlWS.Range("A12").Select
xlApp.ActiveWindow.FreezePanes = True
xlWS.Range("A1").Select

'Save the file and close it
xlWB.Save

xlWB.Close

' Explicitly Clear Memory
'Set xlWS = Nothing
'Set xlWB = Nothing
'Set xlApp = Nothing
'///****End of Format excel workbook****////

'rsDesigner.MoveNext
' Loop
' rsDesigner.Close
' Set rsDesigner = Nothing

MsgBox "Export complete."
End Sub

 

[MarkK]

"Doesn't work" is not enough information. For better results, please describe the actual symptoms of the failure.

 

[Cronk]

I posted the following last month about formatting a word document.

"I work almost exclusively within an Access environment.

When I have a need to manipulate Word documents (or Excel spreadsheets) from withing Access, I find it easiest to record a macro in Word doing manually what is to be programmed, then copy the VBA generated in the Word module into Access, modifying accordingly.

HTH"

 

[pastelrain]

Thanks, MarkK. Sorry it is a Run-time error '5': Invalid procedure call or argument. Debug brings me to the .ListObjects.Add line with the error.