Looping through access tables and creating seperate spreadsheets for each table

[dwinn]

Hello,

I have produced some VBA in Access that creates a spreadsheet.

I have also created an SQL query that retrieves records from an Access table.

I have 48 tables (each table for a specific institution centre).

I have created another bit of VBA code that creates a spreadsheet and loads the records from the query in to the spreadsheet.

Each centre has a unique Sequence Number (Indent Number)

At the moment though, all I can do is import one table (records for one institution) in to a spreadsheet.

I want to end up with calling the function and having an output of 48 spreadsheets being saved to my desktop, each spreadsheet containing records of a different centre.

Does anybody know if there is a way I can do this?

I have thought about putting a loop in, but not sure how I would quite go about it.

Here is my code to create the spreadsheet:

Public Sub ExcelExport(lngIndentNumber As Long, strFolder As String, strCrit As String, strReport As String)
', ctlLabel As Label,
DoCmd.SetWarnings False
Dim tcrit As String
Dim strFileName As String
Dim strIndent As String
Dim strHeading As String
Dim strPaperName As String
Dim strRegionName As String
Dim lngScreenPos As Long
Dim lngNumFields As Long
Dim lngCurrentField As Long
Dim lngWSCurrentRec As Long
Dim lngNumRecs As Long
Dim lngCurrentRec As Long
Dim lngPaperlength As Long
Dim lngCentreLength As Long
Dim lngWorkSheet As Long
Dim cn As ADODB.Connection
Dim rs_report As ADODB.Recordset
Dim strHold As String

'Early Binding
'Dim XlApp As Excel.Application
'Dim xlWorkBook As Excel.Workbook
'Dim xlWorkSheet As Excel.Worksheet

'Late Binding
Dim xlWorkSheet As Object
Dim xlWorkBook As Object
Dim XlApp As Object



strFolder = TrailingSlash(strFolder)

strIndent = RTrim(ReplaceSlash(GetData("select indent from table where pkseqno = " & lngIndentNumber)))
'ctlLabel.Caption = strReport & " " & strIndent & ": 0%"




Set cn = New ADODB.Connection
Set rs_report = New ADODB.Recordset
cn = Application.CurrentProject.Connection
strHeading = strReport & " " & strIndent
strFileName = strHeading & ".xls"

'Early Binding
'Set XlApp = New Excel.Application
'Set xlWorkBook = XlApp.Workbooks.Open(strFileName)
'Late Binding
Set XlApp = CreateObject("Excel.Application")
Set xlWorkBook = XlApp.Workbooks.Add

strFileName = strFolder & strHeading & ".xls"


lngScreenPos = 1   'position on excel sheet to start writing
cn.Open
'Debug.Print tcrit
Set rs_report = cn.Execute(strCrit)
If rs_report.RecordCount > 0 Then
    'now write the data

    rs_report.MoveLast
    lngNumRecs = rs_report.RecordCount
    rs_report.MoveFirst
    lngCurrentRec = 0
    lngWSCurrentRec = 0
    lngWorkSheet = 1
    Do While lngCurrentRec < lngNumRecs
        Set xlWorkSheet = xlWorkBook.Worksheets(lngWorkSheet)
        xlWorkSheet.Name = "Part " & lngWorkSheet
        xlWorkSheet.Range("a" & Format(lngScreenPos)) = strHeading
        lngScreenPos = lngScreenPos + 2
        'write the field headings
        lngNumFields = rs_report.Fields.Count
        lngCurrentField = 0
        Do While lngCurrentField < lngNumFields
            xlWorkSheet.Cells(lngScreenPos, lngCurrentField + 1).Value = rs_report.Fields(lngCurrentField).Name
            xlWorkSheet.Columns(lngCurrentField + 1).ColumnWidth = Len(rs_report.Fields(lngCurrentField).Name)
            lngCurrentField = lngCurrentField + 1
        Loop
            
        Do While lngWSCurrentRec < 64000 And lngCurrentRec < lngNumRecs
            lngScreenPos = lngScreenPos + 1
            lngCurrentField = 0
            Do While lngCurrentField < lngNumFields
                xlWorkSheet.Cells(lngScreenPos, lngCurrentField + 1).Value = "'" & CStr(Nz(rs_report.Fields(lngCurrentField).Value, " "))
                lngCurrentField = lngCurrentField + 1
            Loop
            lngCurrentRec = lngCurrentRec + 1
            lngWSCurrentRec = lngWSCurrentRec + 1
            'If lngCurrentRec Mod 10 = 0 Then
             '   ctlLabel.Caption = strIndent & ": " & lngCurrentRec & " out of : " & lngNumRecs
            'End If
            DoEvents
            rs_report.MoveNext
        Loop
        lngWSCurrentRec = 0
        lngWorkSheet = lngWorkSheet + 1
        lngScreenPos = 1
    Loop

 End If
 rs_report.Close

 strHold = Dir(strFileName)
 If Len(strHold) > 0 Then
    Kill strFileName
 End If

 
'Debug.Print strFileName
'Early Binding
'xlWorkBook.SaveAs strFileName, XlExcel8
'Late Binding


If XlApp.Version = 12 Then
    xlWorkBook.SaveAs strFileName, 56
    Set xlWorkSheet = Nothing
    xlWorkBook.Close False   'need a comma here if ver is prior to 2007
Else
    xlWorkBook.SaveAs strFileName
    Set xlWorkSheet = Nothing
    xlWorkBook.Close False
End If
XlApp.Quit
 
 Set xlWorkBook = Nothing
 Set XlApp = Nothing
 
'Call KillProcess("EXCEL.EXE")
' ctlLabel.Caption = strIndent & ": FINISHED"
 
 MsgBox "FINISHED!"
 
 DoCmd.SetWarnings True
 
 
 Exit Sub

e1:

 MsgBox Error$

 Err.Number = 0

 'Resume

End Sub

Public Sub CreateExcelSpreadsheet()

ExcelExport 985, "C:\Spreadsheet", "qryData", ""


'lngIndentNumber As Long, strFolder As String, ctlLabel As Label, StrCrit As String, strReport As String

End Sub

If anybody can help or advise on this, it would be much appreciated.

Many thanks,

Dan

[Phasma]

Hey Dan
I have accomplished this and will post if you or anyone wants or cares. I know this post has been here a long time and it seems as if it is being overlooked or maybe well ......

Ken

[dwinn]

Hiya,

I am sorry, I didnt realise I hadnt marked this as resolved.

I accomplished this in the end.

Thank you very much for your post though.

Dan