MS Access VBA Excel export find last row for a subtotal

Tasha Parker
Tasha Parker used Ask the Experts™
on
The variables lRow and lCol will only show the correct information on the first loop, the following loops is a report on the first loop. A similar thing happens if I use LastRow variable.


Public Function ExportToExcel(ReportFilterType)
' Tools > References > Microsoft Excel Object Library

On Error GoTo Error_Message
'Requires Reference to Microsoft Excel Object Library
 Dim rsMainList As DAO.Recordset
 Dim rsExport01 As DAO.Recordset
 Dim rsExport02 As DAO.Recordset
 Dim rsExport03 As DAO.Recordset
 Dim sqlExport01 As String, iCol01
 Dim sqlExport02 As String, iCol02
 Dim sqlExport03 As String, iCol03
 Dim xlObj As Object
 Dim xSheet01 As Object 'Upload File
 Dim xSheet02 As Object 'Batch Summary
 Dim xSheet03 As Object 'Batch Detail
 Dim strFolder As String
 Dim LastRow As Long
 
 On Error Resume Next
 DoCmd.Hourglass True
 Set rsMainList = CurrentDb.OpenRecordset("SELECT DISTINCT UPLOAD_ID, VISUAL_BATCH_ID, VISUAL_BATCH_TYPE, VISUAL_DATABASE  FROM VMTBL_NI_VM_ORCL_GL_UPLOAD_STAGING")
 If rsMainList.EOF Then Exit Function
 rsMainList.MoveFirst
 
 strFolder = CurrentProject.Path & "\"
 
 Do Until rsMainList.EOF
   
    Set xlObj = CreateObject("Excel.Application")
    xlObj.Workbooks.Add

    sqlExport01 = "SELECT Database, [Posting Date], [Account Combination], Co, Div, Fun, Rig, Job, AFE, Maj, Min, [I/C], [Debit Amount], " + _
    "[Credit Amount], [Total Amount],[GL Description], [Upload ID], [Batch ID], [Currency ID] " + _
    "FROM UPLOAD_FILE WHERE [Upload ID] ='" & rsMainList![UPLOAD_ID] & "'"
   
    Set rsExport01 = CurrentDb.OpenRecordset(sqlExport01, dbOpenDynaset)
     
    Set xSheet01 = xlObj.ActiveWorkbook.Sheets("sheet1")
     'rename the sheet, you can use any of the recordset field
    xSheet01.Name = "Upload File"
   
    'Adding Sheet02
    With xlObj
    .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
    End With
   
        Set xSheet02 = xlObj.ActiveWorkbook.Sheets("sheet2")
        xSheet02.Name = "Batch Summary"
       
   
    'Adding Sheet03
    With xlObj
    .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
    End With
   
        Set xSheet03 = xlObj.ActiveWorkbook.Sheets("sheet3")
        xSheet03.Name = "Batch Detail"

    'Sheet 01 copy the headers
         For iCol01 = 0 To rsExport01.Fields.Count - 1
             xSheet01.Cells(1, iCol01 + 1).Value = rsExport01.Fields(iCol01).Name
         Next
    xSheet01.Range("A2").CopyFromRecordset rsExport01  'copy the data
   
    'start sqlExport02
    sqlExport02 = "SELECT Database, [Batch Date], [Batch ID], [Batch Amount], Type, Description, [Subtotal By Day], " + _
    "[Grand Total By Month], [Posting Date] " + _
    "FROM BATCH_SUMMARY WHERE [Batch ID] ='" & rsMainList![VISUAL_BATCH_ID] & "'"
   
    Set rsExport02 = CurrentDb.OpenRecordset(sqlExport02, dbOpenDynaset)
   
    'Sheet 02 copy the headers
         For iCol02 = 0 To rsExport02.Fields.Count - 1
             xSheet02.Cells(1, iCol02 + 1).Value = rsExport02.Fields(iCol02).Name
         Next
    xSheet02.Range("A2").CopyFromRecordset rsExport02  'copy the data
       
    'start sqlExport03
    sqlExport03 = "SELECT [Database], [Batch Date], [Batch ID], [Type], [Description], [Posting Date] " + _
    ",[GL Account ID], [GL Description], [Order Trans Date], [Order Trans ID], [Vendor Part ID] " + _
    ",[Vendor Part Name], [Prod Code User PO Ref], [Debit Amount], [Credit Amount], [Account Combination] " + _
    ",[Amount], [Currency ID], [Upload ID] " + _
    "FROM BATCH_DETAIL WHERE [Upload ID] ='" & rsMainList![UPLOAD_ID] & "'"
    Set rsExport03 = CurrentDb.OpenRecordset(sqlExport03, dbOpenDynaset)
   
    'Sheet 03 copy the headers
         For iCol03 = 0 To rsExport03.Fields.Count - 1
             xSheet03.Cells(1, iCol03 + 1).Value = rsExport03.Fields(iCol03).Name
         Next
    xSheet03.Range("A2").CopyFromRecordset rsExport03  'copy the data
   
    Dim lRow As Long
    Dim lCol As Long

      On Error Resume Next
        'Worksheet formatting
        With xlObj
            .Sheets("Batch Detail").Activate ''Batch Detail
            .Cells.Font.Name = "Arial"
            .Cells.Font.Size = 9
            .Rows("2:2").Select
            .ActiveWindow.FreezePanes = True
            .Rows("1:1").Font.Bold = True
            .Rows("1:1").Font.ColorIndex = 1
            .Range("N:N,O:O,Q:Q").NumberFormat = "$#,##0.00"
            .Range("B:B,F:F,I:I").NumberFormat = "mm/dd/yyyy"
            .Columns("A:Z").Select
            .Selection.Columns.AutoFit
            .Rows("1:1").Select
            .Selection.AutoFilter
            .Range("A1").Select
        End With
        On Error Resume Next
        With xlObj
            .Sheets("Batch Summary").Activate 'Batch Summary
            .Cells.Font.Name = "Arial"
            .Cells.Font.Size = 9
            .Rows("2:2").Select
            .ActiveWindow.FreezePanes = True
            .Rows("1:1").Font.Bold = True
            .Rows("1:1").Font.ColorIndex = 1
            .Range("B2,I2").NumberFormat = "mm/dd/yyyy"
            .Range("D2,G2,H2").NumberFormat = "#,##0.00"
            .Columns("A:Z").Select
            .Selection.Columns.AutoFit
            .Range("A1").Select
        End With
        On Error Resume Next
        With xlObj
            .Sheets("Upload File").Activate 'Upload File
            .Cells.Font.Name = "Arial"
            .Cells.Font.Size = 9
            .Rows("2:2").Select
            .ActiveWindow.FreezePanes = True
            .Rows("1:1").Font.Bold = True
            .Rows("1:1").Font.ColorIndex = 1
            .Range("M:M,N:N,O:O").NumberFormat = "$#,##0.00"
            .Range("B:B").NumberFormat = "mm/dd/yyyy"
            .Rows("1:1").Select
            .Selection.AutoFilter
            .Columns("A:Z").Select
            .Selection.Columns.AutoFit
           
            lRow = .Cells(Rows.Count, 1).End(xlUp).Row
            'Find the last non-blank cell in row 1
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            MsgBox "Last Row: " & lRow & vbNewLine & _
                    "Last Column: " & lCol
                   
            'LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            'MsgBox LastRow
            '.Range("O" & LastRow + 1).Formula = "=SUM(O2:O" & LastRow & ")"
            .Range("A1").Select
        End With
        On Error Resume Next
       
    'Save file
    xlObj.Application.DisplayAlerts = False
    'check for open file and close
   
    Dim txtfilename As String
    txtfilename = strFolder & rsMainList![VISUAL_DATABASE] & "-" & rsMainList![VISUAL_BATCH_ID] & "-" & rsMainList![VISUAL_BATCH_TYPE] & ".xlsx"
   
        Dim Wkb As Workbook
        If Dir(txtfilename) <> "" Then
        Set Wkb = Workbooks.Open(txtfilename)
        Wkb.Close Savechanges:=True
        End If
       
    xlObj.ActiveWorkbook.SaveAs txtfilename, FileFormat:=51, CreateBackup:=False
    'lObj.ActiveWorkbook.SaveAs strFolder & rsMainList![VISUAL_DATABASE] & "-" & rsMainList![VISUAL_BATCH_ID] & "-" & rsMainList![VISUAL_BATCH_TYPE] & ".xlsx", FileFormat:=51, CreateBackup:=False
    xlObj.Quit
    xlObj.Application.DisplayAlerts = True
     Set xSheet01 = Nothing
     Set xSheet02 = Nothing
     Set xSheet03 = Nothing
     Set xlObj = Nothing
    'On Error Resume Next
    rsMainList.MoveNext
    Loop
   
   
Close_Objects:
On Error Resume Next
    DoCmd.Hourglass False
    rsMainList.Close
    rsExport01.Close
    rsExport02.Close
    rsExport03.Close
    Set rsMainList = Nothing
    Set rsExport01 = Nothing
    Set rsExport02 = Nothing
    Set rsExport03 = Nothing
    MsgBox "Before proceeding review the Excel files found in the following directory: " & strFolder

Error_Message:
    'MsgBox Error$
    'Resume Close_Objects

End Function
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Software & Systems Engineer
Commented:
Just move
Dim lRow As Long
Dim lCol As Long

Open in new window


under
.....
.....
Dim strFolder As String
 Dim LastRow As Long
Dim lRow As Long
Dim lCol As Long

Open in new window

Author

Commented:
You saved me from pulling out my hair!!
Thank you!!
John TsioumprisSoftware & Systems Engineer

Commented:
Happy i saved you hair...:)

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial