CODEWITHSUNDEEP
excelvbams-accessexport-to-excelspreadsheet
Emil Visti
Emil Visti

Reputation: 55

Export my Access table to Excel, but split different value in a column into different worksheets

I am using Access VBA to export a table to Excel for a colleague and it would be extremely handy if the output could be split into different worksheets in the same workbook depending on and named after the value in column 1.

This is the code I'm currently using to export the entire table to a new Workbook in Excel:

Private Sub export_Click()

    If IsNull(DLookup("Name", "MSysObjects", "Name='tbl_found_playingtimes'")) Then
        MsgBox ("No records to export.")
    Else

        Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlsheet As Excel.Worksheet

        Dim rs1 As DAO.Recordset

        DoCmd.Hourglass (True)

        Set rs1 = CurrentDb.OpenRecordset("tbl_found_playingtimes")

        Set xlApp = Excel.Application
        xlApp.Visible = False
        Set xlBook = xlApp.Workbooks.Add
        Set xlsheet = xlBook.Worksheets(1)

        With xlsheet

            .Name = "test"
            .Columns("I").NumberFormat = "0,00"
            .Range("A2").CopyFromRecordset rs1

            For cols = 0 To rs1.Fields.Count - 1
                .Cells(1, cols + 1).Value = rs1.Fields(cols).Name
            Next

        End With

    End If

SubExit:
On Error Resume Next
    DoCmd.Hourglass False
    xlApp.Visible = True
    Exit Sub

End Sub

This works well enough, except for some snags - A number column not getting exported - But my primary concern is if I could split it up. Each label number would be in its own worksheet named after the label number.

Sample data from the Access Table

Upvotes: 0

Views: 721

Answers (1)

Applecore
Applecore

Reputation: 4099

What you need to do is to have an "outer" recordset that contains the unique list of label numbers, and then loop through this, outputting filtered data to each worksheet. Something like this should get you started:

Sub sExportExcel()
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim db As DAO.Database
    Dim rsLabel As DAO.Recordset
    Dim rsData As DAO.Recordset
    Dim strSQL As String
    Dim lngLoop1 As Long
    Dim lngCount As Long
    Set db = DBEngine(0)(0)
    strSQL = "SELECT DISTINCT [label no] FROM tbl_found_playing_times ORDER BY [label no] ASC;"
    Set rsLabel = db.OpenRecordset(strSQL)
    If Not (rsLabel.BOF And rsLabel.EOF) Then
        Set xlBook = xlApp.Workbooks.Add
        Do
            Set xlSheet = xlBook.Worksheets.Add(After:=xlBook.Worksheets(xlBook.Worksheets.Count))
            xlSheet.name = rsLabel("label no")
            strSQL = "SELECT * FROM tbl_found_playing_times WHERE [label no]=" & rsLabel("label no")
            Set rsData = db.OpenRecordset(strSQL)
            If Not (rsData.BOF And rsData.EOF) Then
                xlSheet.Range("A2").CopyFromRecordset rsData
            End If
            rsLabel.MoveNext
        Loop Until rsLabel.EOF
        lngCount = xlBook.Worksheets.Count
        For lngLoop1 = lngCount To 1 Step -1
            If Left(xlBook.Worksheets(lngLoop1).name, 5) = "Sheet" Then
                xlBook.Worksheets(lngLoop1).Delete
            End If
        Next lngLoop1
        xlBook.Worksheets(1).Select
        xlApp.Visible = True
    End If  
End Sub

Regards,

Upvotes: 1

Related Questions