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!
Code:
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