Advanced Export To Excel

[TH53]

Hello Everyone, great forum you have here. First time posting and hoping one of you can help me complete my project. I'm a novice at programing databases but feel I am picking it up fairly quickly. What I would like to do is create a report the is based off of several tables and queries in a database. currently the code I'm using allows me to export single tables to single work sheets which is ok but I would like something different. What I would like to do is to be able to export multiple tables/queries to both separate worksheets and export multiple queries to a single worksheet. The Excel workbook will be a template that will have a lot of formatting and charts/graphs that are based on the information that is imported from access. If possible I would like to be able to select the range that each table is imported to and to be able to name the sheet or specify the name of the sheet to which it is imported. Below is the code I am currently using and it works fine but does not allow me to export multiple tables to the same worksheet or define the range that data is imported to. The data import range is set for all of the sheets. I would like to state that the code was written for me by a gentleman named Diego and many thanks go out to him for helping me get this far. Any help is greatly appreciated.



Thank you!

Option Compare Database
'------------------------------------------------------------
' Command8_Click
'
'------------------------------------------------------------
Private Sub Command8_Click()
On Error GoTo Command8_Click_Err
DoCmd.SetWarnings False

DoCmd.OpenQuery "Deltestrep", acViewNormal, acEdit
DoCmd.OpenQuery "deltestsell", acViewNormal, acEdit
DoCmd.OpenQuery "DeleteRepairingQry", acViewNormal, acEdit
DoCmd.OpenQuery "TestRepQry", acViewNormal, acEdit
DoCmd.OpenQuery "TestSellQry", acViewNormal, acEdit
DoCmd.OpenQuery "RepairingOutputTblQry", acViewNormal, acEdit

Dim strPath As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String


strPath = "C:\Users\****\DesktopTest.xltx"

strSQL1 = "TestRepQryTbl" & "|Repairing"
strSQL2 = "TestSellQryTbl" & "|Selling"
strSQL3 = "RepairingQryTbl" & "|Repairing Op-Codes"

Call SqlsToExcel(strPath, strSQL1, strSQL2, strSQL3)
 
Command8_Click_Exit:
    Exit Sub
Command8_Click_Err:
    MsgBox Error$
    Resume Command8_Click_Exit
End Sub
 

Sub SqlsToExcel(strFile As String, ParamArray strSQLs())
On Error GoTo ErrorHandler
    Dim dbs     As DAO.Database
    Dim rst     As DAO.Recordset
    Dim xlAp    As Excel.Application
    Dim xlWb    As Excel.Workbook
    Dim xlws    As Excel.Worksheet
    Dim i       As Long
    Dim j       As Long
    Dim j1      As Long
    Dim k       As Long
    Dim x       As Long
    Dim vaHd()  As String
    Dim Data
    Dim strsql As String
    Dim strName As String
    Dim aSQL
  
   
    
    
    Set dbs = CurrentDb
    Set xlAp = CreateObject("Excel.Application")
    Set xlWb = xlAp.Workbooks.Open("C:\Users\***\Desktop\Test.xltx")
   
    For i = 0 To UBound(strSQLs)
    
   aSQL = Split(strSQLs(i), "|")
   strsql = Trim(aSQL(0))
   strName = Trim(aSQL(1))
        
       If i = 0 Then
           Set xlws = xlWb.Worksheets("sheet" & i + 1)
           xlws.Name = strName
           
        
       ElseIf i = 1 Then
            Set xlws = xlWb.Worksheets("sheet" & i + 1)
            xlws.Name = strName
            
         
       ElseIf i = 2 Then
       Set xlws = xlWb.Worksheets("sheet" & i + 1)
       xlws.Name = strName
       
        ElseIf i = 3 Then
       Set xlws = xlWb.Worksheets("sheet" & i + 1)
       xlws.Name = strName
        End If
            
        Set rst = dbs.OpenRecordset(strsql)
        
        With rst
            .MoveLast
            j = .Fields.Count
            j1 = j - 1
            k = .RecordCount
            ReDim vaHd(j)
            .MoveFirst
            For x = 0 To j1
                vaHd(x) = .Fields(x).Name
           Next
            
            With xlWb
              xlws.Cells(2, 1).Resize(1, j) = vaHd
              Data = xlws.Cells(3, 1).CopyFromRecordset(rst)
            End With
    
   End With
   
     With xlws
                 With .UsedRange
                    .Columns.AutoFit
                    .Rows.AutoFit
                     End With

              
         
            Set xlws = xlWb.Sheets("Repairing")
     
               
      
            
        xlws.Range("A1") = " Claims Repaired By " & [Forms]![TestForm]![DlrCdBx] & " - " & [Forms]![TestForm]![DateFromBx] & " - " & [Forms]![TestForm]![DateToBx]
        
                   
              End With
                   
     
        Set xlws = Nothing
       
    Next i
    
    Set xlws = xlWb.Sheets("Selling")
    
     
        
        xlws.Range("A1") = " Claims On Contracts Sold By " & [Forms]![TestForm]![DlrCdBx] & " - " & [Forms]![TestForm]![DateFromBx] & " - " & [Forms]![TestForm]![DateToBx]
       
     
      Set xlws = Nothing
      
    
    
    Set xlws = xlWb.Sheets("Repairing Op-Codes")
    
    xlws.Range("A1") = [Forms]![TestForm]![DlrCdBx] & " - Repairing Dealer Op Code Report" & " - " & [Forms]![TestForm]![DateFromBx] & " - " & [Forms]![TestForm]![DateToBx]
              
     Set rngdata = xlws.Range("A3").CurrentRegion
    With rngdata.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
     With rngdata.Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
    End With
     With rngdata
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
    End With
    
    Set xlws = Nothing
    
    
    Set rst = Nothing
    
   xlAp.Visible = True
           
 
 
ExitFunction:
    If Not xlws Is Nothing Then
      Set xlws = Nothing
    End If
    
    If Not xlWb Is Nothing Then
      Set xlWb = Nothing
    End If
    If Not xlAp Is Nothing Then
      xlAp.Quit
    End If
       
    Exit Sub
ErrorHandler:
    Select Case Err.Number
      Case 0
      Case Else
          MsgBox Err.Number & ": " & Err.Description
          Resume ExitFunction
    End Select
End Sub

[June7]

Have to ask, why export? Access has graphing capability, not as versatile as Excel but can do a lot. All my graphing is done within Access.

Have you considered coding behind Excel instead to import from Access?

[TH53]

Hi June, thanks for your reply, to be completely honest my knowledge of access is fairly limited and I can get more professional looking results exporting to excel. Also the excel reports tend to be more user friendly and they will be used by quite a few people.