How Export Access Database More Than 1 Million Rows

[jusho]

Please help,

I want to export 6 million row of access database into access.
I got a vba code but it only export 1 sheet (max 1048576 row).
I need to export to excel into multiplesheet is fine for me.

Here my existing code

Option Compare DatabaseOption Explicit


Sub Test()
    
    'Change the names according to your own needs.
    DataToExcel "ciftabgirloan201412_20150109", "C:\Users\wildan.pratama\Documents\Tabungan\Analisa Tabungan Memiliki Pinjaman\test.xlsx", "Data"
                
    'Just showing that the operation finished.
    MsgBox "Data export finished successfully!", vbInformation, "Done"
    
End Sub


 Function DataToExcel(strSourceName As String, Optional strWorkbookPath As String, Optional strTargetSheetName As String)
 
    'Use this function to export a large table/query from your database to a new Excel workbook.
    'You can also specify the name of the worksheet target.
    
    'strSourceName is the name of the table/query you want to export to Excel.
    'strWorkbookPath is the path of the workbook you want to export the data.
    'strTargetSheetName is the desired name of the target sheet.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net
   
    Dim rst         As DAO.Recordset
    Dim excelApp    As Object
    Dim Wbk         As Object
    Dim sht         As Object
    Dim fldHeadings As DAO.Field
        
    'Set the desired recordset (table/query).
    Set rst = CurrentDb.OpenRecordset(strSourceName)
    
    'Create a new Excel instance.
    Set excelApp = CreateObject("Excel.Application")
    
    On Error Resume Next
    
    'Try to open the specified workbook. If there is no workbook specified
    '(or if it cannot be opened) create a new one and rename the target sheet.
    Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
    If Err.Number <> 0 Or Len(strWorkbookPath) = 0 Then
        Set Wbk = excelApp.Workbooks.Add
        Set sht = Wbk.Worksheets("Sheet1")
        If Len(strTargetSheetName) > 0 Then
            sht.Name = Left(strTargetSheetName, 34)
        End If
    End If
    
    'If the specified workbook has been opened correctly, then in order to avoid
    'problems with other sheets that might contain, a new sheet is added and is
    'being renamed according to the strTargetSheetName.
    Set sht = Wbk.Worksheets.Add
    If Len(strTargetSheetName) > 0 Then
        sht.Name = Left(strTargetSheetName, 34)
    End If
            
    On Error GoTo 0
    
    excelApp.Visible = True
                               
    On Error GoTo Errorhandler


    'Write the headings in the target sheet.
    For Each fldHeadings In rst.Fields
        excelApp.ActiveCell = fldHeadings.Name
        excelApp.ActiveCell.Offset(0, 1).Select
    Next
    
    'Copy the data in the target sheet.
    rst.MoveFirst
    sht.Range("A2").CopyFromRecordset rst
    sht.Range("1:1").Select
    
    'Format the headings of the target sheet.
    excelApp.Selection.Font.Bold = True
    With excelApp.Selection
        .HorizontalAlignment = -4108 '= xlCenter in Excel.
        .VerticalAlignment = -4108  '= xlCenter in Excel.
        .WrapText = False
        With .Font
            .Name = "Arial"
            .Size = 11
        End With
    End With
    
    'Adjusting the columns width.
    excelApp.ActiveSheet.Cells.EntireColumn.AutoFit
    
    'Freeze the first row - headings.
    With excelApp.ActiveWindow
        .FreezePanes = False
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    sht.Rows("2:2").Select
    excelApp.ActiveWindow.FreezePanes = True
    
    'Change the tab color of the target sheet.
    With sht
        .Tab.Color = RGB(255, 0, 0)
        .Range("A1").Select
    End With


    'Close the recordset.
    rst.Close
    Set rst = Nothing


Exit Function


Errorhandler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function


End Function

Thanks for your help

 

[Joe4]

See here: Importing Big Text Files Into Excel