amanphilip
New Member
- Joined
- Jul 4, 2023
- Messages
- 18
- Office Version
- 365
- 2019
- Platform
- Windows
Dear All,
I currently have a small VBA project where it will import data from excel sheet to MS-Access. Excel sheet contains 163 columns and 141k rows. However it takes about 5 minutes to process 1000 rows. Is there anyway i can make my code more efficient to speed up the process of importing? If my calculation is right it will take about 11 hours to complete importing the whole 141k rows. Here's my code below:
I currently have a small VBA project where it will import data from excel sheet to MS-Access. Excel sheet contains 163 columns and 141k rows. However it takes about 5 minutes to process 1000 rows. Is there anyway i can make my code more efficient to speed up the process of importing? If my calculation is right it will take about 11 hours to complete importing the whole 141k rows. Here's my code below:
VBA Code:
Sub exporttodb()
Dim db As Object
Dim rs As Object
Dim conn As Object
Dim strsql As String
Dim accessDB As String
Dim tablename As String
Dim dataarray() As Variant
Dim batchsize As Long
Dim i As Long
Dim j As Long
Dim wbs As Workbook
Dim ws As Worksheet
Dim fd As FileDialog
Dim selws As Worksheet
Dim lastcol As Integer
Dim lastrow As Long
Dim selectedfile As Object
Dim listboxcounter As Integer
Dim currentTotalRecords As Long
Dim currentrowrecord As Long
'set the DB path and table name
accessDB = ThisWorkbook.Worksheets("References").Range("F1").Value & ThisWorkbook.Worksheets("References").Range("F2").Value
tablename = "Consolidated Inventory+FFE 2"
'Create Access Database and recordset objects
Set db = CreateObject("Access.Application")
db.opencurrentdatabase accessDB
Set rs = db.currentdb.openrecordset(tablename)
'set the connection string for the recordset and delete the existing records.
Set conn = CreateObject("ADODB.Connection")
conn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessDB & ";")
strsql = "DELETE * FROM [" & tablename & "];"
conn.Execute strsql
'Import the records.
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.AllowMultiSelect = False
.Title = "Select Workbooks"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xslm; *.xlsb", 1
If .Show - 1 Then
For Each selItems In .SelectedItems
Set wbs = Workbooks.Open(selItems)
For Each ws In wbs.Sheets
listboxcounter = listboxcounter + 1
'Add the sheetnames in the listbox
Sheetsel.ListBox1.AddItem ws.Name
Next ws
Sheetsel.Show
Next selItems
End If
'Prepare the data for export
If selectedv <> "" Then
Set selws = wbs.Worksheets(selectedv)
lastcol = selws.Cells(1, selws.Columns.Count).End(xlToLeft).Column
lastrow = selws.Cells(selws.Rows.Count, 2).End(xlUp).Row
End If
End With
batchsize = 1000
currentTotalRecords = rs.RecordCount
'Loop through the data in batchsize
For currentrowrecord = 2 To lastrow Step batchsize
'resize the array to matcht the data in the current batch
ReDim dataarray(1 To batchsize, 1 To lastcol)
'populate the array with data from the source sheet
For i = 1 To batchsize
For j = 1 To lastcol
dataarray(i, j) = selws.Cells(currentrowrecord + i - 1, j).Value
Next j
Next i
'Insert the batch to the access db
On Error Resume Next
For i = 1 To batchsize
rs.AddNew
For j = 1 To lastcol
rs.Fields(j - 1).Value = dataarray(i, j)
Next j
rs.Update
Next i
Next currentrowrecord
End Sub