MS Access VBS to export Datasheet view to excel format

[Mavericks334]

Hi,

I am trying to export an access data sheet view to excel with certain formatting. Below is the code unfortunately it does not seem to work

Function Create_Dept_Recalc_Report(FileName As String) As Object
Dim H$(2, 30), N$, S$
Dim SourceRow As Long, LastSourceRow As Long, ReportRow As Long, LastReportRow As Long, RR As Long, CC As Long
Dim ThisDeptName$, NextDeptName$, ThisDeptCode$, NextDeptCode$, SectionStartRow As Long, SectionEndRow As Long
Dim FirstBrCo$, FirstQtrYr$, FirstDeptCode$, FirstDeptRate$
Dim GotBigDiffs As Boolean, Qtd_Diff As Currency, Ytd_Diff As Currency
'
Set myXl = CreateObject("excel.sheet")
'Set myBk = myXl.Workbooks.Open(filename)
'Sub Add_Subtotals_And_Format_Report_Hot_Key_S()
 With myXl.Application
   .Workbooks.Open FileName
'
'Set some values--
  N$ = "NEW REPORT": S$ = "SOURCE DATA"
  GotBigDiffs = False
  
'Create the new report page--
If GotSheet(N$) Then
  Application.DisplayAlerts = False
  .Sheets(N$).Delete
  Application.DisplayAlerts = True
End If
.Sheets.Add before:=.Sheets(1)
ActiveSheet.Name = N$


'Format the excelsheet--
 .Sheets(N$).PageSetup.Orientation = xlLandscape
 .Sheets(N$).PageSetup.TopMargin = Application.InchesToPoints(0.25)
 .Sheets(N$).PageSetup.BottomMargin = Application.InchesToPoints(0.25)
 .Sheets(N$).PageSetup.LeftMargin = Application.InchesToPoints(0#)
 .Sheets(N$).PageSetup.RightMargin = Application.InchesToPoints(0#)
 .Sheets(N$).PageSetup.PrintTitleRows = "$1:$2"
 .Sheets(N$).PageSetup.Zoom = 65
  .Rows("3:3").Select: ActiveWindow.FreezePanes = True


'Put the report headings into the new Excel sheet--
  FirstBrCo$ = TU$(.Sheets(S$).Cells(2, 1))
  FirstQtrYr$ = TU$(.Sheets(S$).Cells(2, 2))
  FirstDeptCode$ = TU$(.Sheets(S$).Cells(2, 6))
  FirstDeptRate$ = TS$(.Sheets(S$).Cells(2, 7))
 
   Range("A1").Font.Size = 20: Range("A1").Font.Bold = True
 .Cells(3, 1) = "Wage & Tax Detail"
   Range("A3").Font.Size = 16: Range("A3").Font.Bold = True


'Put the first (dummy) section headings in--
 Call PutInSectionHeadings("DUMMY Dept", "XX/XXXX", 5)


'Now copy the report data into the spreadsheet--
LastSourceRow = .Sheets(S$).Cells(65530, 1).End(xlUp).Row
For SourceRow = 2 To LastSourceRow
 .Sheets(N$).Cells(SourceRow + 5, 1) = .Sheets(S$).Cells(SourceRow, 1) 'Lo code
 .Sheets(N$).Cells(SourceRow + 5, 2) = .Sheets(S$).Cells(SourceRow, 2) 'qtr/yr
 .Sheets(N$).Cells(SourceRow + 5, 3) = .Sheets(S$).Cells(SourceRow, 3) 'ee file #
 .Sheets(N$).Cells(SourceRow + 5, 4) = .Sheets(S$).Cells(SourceRow, 4) 'PH#
 .Sheets(N$).Cells(SourceRow + 5, 5) = .Sheets(S$).Cells(SourceRow, 5) 'ee name
 .Sheets(N$).Cells(SourceRow + 5, 6) = .Sheets(S$).Cells(SourceRow, 6) 'Dept code
 .Sheets(N$).Cells(SourceRow + 5, 7) = .Sheets(S$).Cells(SourceRow, 7) 'Dept rate
 .Sheets(N$).Cells(SourceRow + 5, 8) = .Sheets(S$).Cells(SourceRow, 8) 'qtd 
 .Sheets(N$).Cells(SourceRow + 5, 9) = .Sheets(S$).Cells(SourceRow, 9) 'qtd avg
 .Sheets(N$).Cells(SourceRow + 5, 10) = .Sheets(S$).Cells(SourceRow, 10) 'qtr wh
 .Sheets(N$).Cells(SourceRow + 5, 11) = 0.01 * Int(.Sheets(N$).Cells(SourceRow + 5, 7) * .Sheets(N$).Cells(SourceRow + 5, 9)) 'qtd calc tax
 .Sheets(N$).Cells(SourceRow + 5, 12) = .Sheets(N$).Cells(SourceRow + 5, 11) - .Sheets(N$).Cells(SourceRow + 5, 10) 'qtd diff
 .Sheets(N$).Cells(SourceRow + 5, 13) = "" 'blank dividing olumn
 .Sheets(N$).Cells(SourceRow + 5, 14) = .Sheets(S$).Cells(SourceRow, 13) 'ytd  
 .Sheets(N$).Cells(SourceRow + 5, 15) = .Sheets(S$).Cells(SourceRow, 14) 'ytd Avg
 .Sheets(N$).Cells(SourceRow + 5, 16) = .Sheets(S$).Cells(SourceRow, 15) 'ytd  wh
 .Sheets(N$).Cells(SourceRow + 5, 17) = 0.01 * Int(.Sheets(N$).Cells(SourceRow + 5, 7) * .Sheets(N$).Cells(SourceRow + 5, 15)) 'ytd calc tax
 .Sheets(N$).Cells(SourceRow + 5, 18) = .Sheets(N$).Cells(SourceRow + 5, 17) - .Sheets(N$).Cells(SourceRow + 5, 16) 'ytd diff
 .Sheets(N$).Cells(SourceRow + 5, 19) = .Sheets(S$).Cells(SourceRow, 18) 'Dept N name
 Qtd_Diff = .Sheets(N$).Cells(SourceRow + 5, 12): Ytd_Diff = .Sheets(N$).Cells(SourceRow + 5, 18)
 If Abs(Qtd_Diff) + Abs(Ytd_Diff) > 1 Then GotBigDiffs = True: .Sheets(N$).Cells(SourceRow + 5, 20) = Abs(Qtd_Diff) + Abs(Ytd_Diff) Else .Sheets(N$).Cells(SourceRow + 5, 20) = "0.00"
Next SourceRow


 'Sort the.Rows by Dept code/difference flag/ee name--
  .Sheets(N$).Range("A7:T" + TS$(LastSourceRow + 5)).Select
  If GotBigDiffs Then
    Selection.Sort Key1:=.Sheets(N$).Range("F7"), Order1:=xlAscending, Key2:=.Sheets(N$).Range("T7"), Order2:=xlDescending, Key3:=.Sheets(N$).Range("E7"), Order3:=xlAscending
  Else
    Selection.Sort Key1:=.Sheets(N$).Range("F7"), Order1:=xlAscending, Key2:=.Sheets(N$).Range("E7"), Order2:=xlAscending
  End If
  Range("A1").Select
    
'Now insert the section headings--
 SectionStartRow = 7: LastReportRow = .Sheets(N$).Cells(65530, 1).End(xlUp).Row
 ReportRow = 7
 Do Until ReportRow > LastReportRow + 1
  ThisDeptName$ = TU$(.Sheets(N$).Cells(ReportRow, 19))
  NextDeptName$ = TU$(.Sheets(N$).Cells(ReportRow + 1, 19))
  ThisDeptCode$ = TU$(.Sheets(N$).Cells(ReportRow, 6))
  NextDeptCode$ = TU$(.Sheets(N$).Cells(ReportRow + 1, 6))
 
 'If this is the end of one section and start of next section-- then insert the prev totals and next headings
  If ThisDeptName$ <> NextDeptName$ Or ThisDeptCode$ <> NextDeptCode$ Then
'  MsgBox (ThisDeptName + ", " + NextDeptName$ + "  --  " + ThisDeptCode$ + ", " + NextDeptCode$)
  If ThisDeptName$ <> "" Or ThisDeptCode$ <> "" Then
   SectionEndRow = ReportRow
   For RR = 1 To 5
     .Sheets(N$).Rows(ReportRow + 1).Insert shift:=xlDown
   Next RR
   .Sheets(N$).Rows(ReportRow + 1).Font.Bold = True
   .Sheets(N$).Cells(ReportRow + 1, 1) = "TOTALS--"
   For CC = 8 To 18
     .Sheets(N$).Cells(ReportRow + 1, CC) = "=SUM(" + Alph$(CC) + TS$(SectionStartRow) + ":" + Alph$(CC) + TS$(SectionEndRow) + ")"
   Next CC
   LastReportRow = .Sheets(N$).Cells(65530, 1).End(xlUp).Row
  End If
   If SectionStartRow = 7 Then Call PutInSectionHeadings(ThisDeptName$, ThisDeptCode$, 5)
   If NextDeptName$ <> "" Then Call PutInSectionHeadings(NextDeptName$, NextDeptCode$, ReportRow + 4)
   SectionStartRow = ReportRow + 5: ReportRow = SectionStartRow
  End If  'if this is the end of one section and start of next section-- then insert the prev totals and next headings
  ReportRow = ReportRow + 1
 Loop
'Highlight any.Rows with diff> $1.00
 LastReportRow = .Sheets(N$).Cells(65530, 1).End(xlUp).Row
 For ReportRow = 7 To LastReportRow
    If Val(.Sheets(N$).Cells(ReportRow, 20)) > 0 Then .Sheets(N$).Range("A" + TS$(ReportRow) + ":R" + TS$(ReportRow)).Interior.Color = 10092543
 Next ReportRow
 
 
'Adjust the column formats/widths--
  .Sheets(N$).Columns("H:R").NumberFormat = "#,##0.00"
  .Sheets(N$).Columns.AutoFit
  .Sheets(N$).Columns(1).ColumnWidth = 6.43
  .Sheets(N$).Columns(13).ColumnWidth = 1
  .Sheets(N$).Columns("S:T").ClearContents
  MsgBox ("ALL DONE")
 End with
End Sub




Private Function GotSheet(ByVal P$) As Boolean
Dim S As Integer, ST As Integer
ST = .Sheets.Count: GotSheet = False
For S = 1 To ST
  If TU$(.Sheets(S).Name) = TU$(P$) Then GotSheet = True: Exit For
Next S
End Function




Private Function TU$(ByVal ThisStr$)
  TU$ = Trim(UCase$(ThisStr$))
End Function


Private Function TS$(ByVal ThisVal As Long)
  TS$ = Trim(Str$(ThisVal))
End Function




Private Function PutInSectionHeadings(DeptName$, DeptCode$, StartRow As Long)
Dim H$(2,30),RR as long,CC as Integer
  For RR = 1 To 2: For CC = 1 To 30: H$(RR, CC) = "": Next CC: Next RR
  For CC = 8 To 12: H$(1, CC) = "QTD": H$(1, CC + 6) = "YTD": Next CC
  H$(2, 1) = "Co #": H$(2, 2) = "Qtr/Yr": H$(2, 3) = "FILE #": H$(2, 4) = "SSN": H$(2, 5) = "EE NAME": H$(2, 6) = "Dept": H$(2, 7) = "Rate": H$(2, 8) = " Subj": H$(2, 9) = "Dept Txbl"
  H$(2, 10) = "Tax Wh": H$(2, 11) = "Calc Tax": H$(2, 12) = "Difference": H$(2, 13) = "": H$(2, 14) = " Subj": H$(2, 15) = "Dept Txbl": H$(2, 16) = "Tax Wh":  H$(2, 17) = "Calc Tax": H$(2, 18) = "Difference"


 .Cells(StartRow, 1) = "Jurisdiction: " + DeptName$ + " (" + Trim(DeptCode$) + ")--"
  .Cells(StartRow, 1).Font.Underline = xlUnderlineStyleSingle
  For CC = 8 To 18:.Cells(StartRow, CC) = H$(1, CC): Next CC
  For CC = 1 To 18:.Cells(StartRow + 1, CC) = H$(2, CC): Next CC
 .Rows(TS$(StartRow) + ":" + TS$(StartRow + 1)).Font.Bold = True
 .Rows(TS$(StartRow) + ":" + TS$(StartRow + 1)).Font.Size = 12
 .Rows(TS$(StartRow) + ":" + TS$(StartRow + 1)).HorizontalAlignment = xlCenter
 .Cells(StartRow, 1).HorizontalAlignment = xlGeneral
 .Cells(StartRow + 1, 1).HorizontalAlignment = xlGeneral
End Function




Private Function Alph$(ByVal ThisVal)
 'MACRO TO CONVERT COLUMN NUMBER (=BASE 10 in digits 0-9) TO COLUMN LETTER (=BASE 26 in letters)--
  Dim P As Integer, Mult As Integer
 Alph$ = ""
 If ThisVal > 26 ^ 3 Then MsgBox ("INVALID COLUMN NUMBER")
 For P = 2 To 0 Step -1
  If ThisVal > 26 ^ P Then
     Mult = Int((ThisVal) / 26 ^ P)
     Alph$ = Alph$ + Chr$(Mult + 64)
     ThisVal = ThisVal - 26 ^ P * Mult
  End If
  Next P
  If ThisVal = 1 Then Alph$ = Alph$ + "A"
End Function




Private Function Numz(ByVal ThisAlph$) As Long
 'MACRO TO CONVERT COLUMN LETTER (=BASE 26 in letters) TO COLUMN NUMBER (=BASE 10 in digits 0-9)--
  Dim P As Integer, X As Integer
  'Is the column number more than 26??
  Numz = 0: P = 0
  ThisAlph$ = Trim$(UCase$(ThisAlph$))
  For X = Len(ThisAlph$) To 1 Step -1
     Numz = Numz + 26 ^ P * (Asc(Mid$(ThisAlph$, X, 1)) - 64)
     P = P + 1
  Next X
End Function

Regards,
Renato.

 

[ranman256]

export the data first
docmd.transferspreadsheet .....

then open it in myXL to do the formatting.