I've been working on this database for a while now and have become stuck with a couple issues I am having with the database, this being one of them.
This code transfers a table into excel, putting each 1,000,000 records on a separate sheet. The current table I am attempting to transfer has just under 1.5 millions records and 7 fields.
The coding works fine until it hits the Alter Table SQL. At which point it spits out this error. I have already increased the dbMaxLocksPerFile to 20 million, and this hasn't helped and I am stumped.
Any help I could get on this would be amazing :)
FYI This is the first lot of VBA programming I've ever done, and am self-taught (google taught), so my set out and such may be a bit messy. The code is below:
Private Sub EXPORT_TO_EXCEL_Click()
DAO.DBEngine.SetOption dbMaxLocksPerFile, 20000000 'That's 20 million!!!
'DTable is the file name, and is input by the user in earlier coding under a public string
Call CreateNewFolder("O:\Folder Location\" & DTable & "")
Dim strWorksheetPathTable As String
'----Set File Path
strWorksheetPathTable = "O:\Folder Location"
strWorksheetPathTable = strWorksheetPathTable & "" & DTable & "\" & DTable & ".xlsb"
'----SPLIT DATA TABLE IN ACCESS THEN EXPORT THESE SMALLER TABLES (Splits if over 1,000,000 records)
Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection
Set cn = CurrentProject.Connection
Dim rowcount As Long
Dim tblcount As Integer
Dim i As Integer
Dim tblx As String
Dim dbsDatas As DAO.Database
Set dbsDatas = CurrentDb
SQL = "SELECT * INTO tmpdata FROM [" & DTable & "]"
SQL = "ALTER TABLE tmpdata ADD COLUMN id COUNTER"
SQL = "SELECT count(*) as rowcount from [" & DTable & "]"
rs.Open SQL, cn
rowcount = rs!rowcount
tblcount = rowcount / 1000000 + 1
For i = 1 To tblcount
SQL = "SELECT * into tmpdata" & i & " FROM tmpdata" & _
" WHERE id<=1000000*" & i
SQL = "DELETE * FROM tmpdata" & _
" WHERE id<=1000000*" & i
DoCmd.TransferSpreadsheet transfertype:=acExport, _
TableName:="tmpdata" & i & "", FileName:=strWorksheetPathTable, _
Range:="Data" & i & ""
DoCmd.DeleteObject acTable, "tmpdata" & i & ""
DoCmd.DeleteObject acTable, "tmpdata"
MsgBox ("Report saved at the following location: " & strWorksheetPathTable & "")
I'm unsure if anyone will find this helpful, but my method of getting around this was to copy the table to a
txt file and then copy it from here 1,000,000 records at a time into separate excel sheets.
EXPORT TO TXT
Private Sub EXPORT_TO_TEXT_FILE_Click() Dim txtFile As String, rs As DAO.Recordset, j As Integer, strFld As String, strData As String txtFile = "O:\GData\Downstream\DWN Data Mgmt\CEDAL\Reports\" & NewFileName & ".txt" Set rs = CurrentDb.OpenRecordset("" & NewFileName & "") For j = 0 To rs.Fields.Count - 1 strFld = strFld & vbTab & rs(j).Name Next Open txtFile For Output As #1 Print #1, Mid(strFld, 2) Do Until rs.EOF For j = 0 To rs.Fields.Count - 1 strData = strData & vbTab & rs(j) Next Print #1, Mid(strData, 2) strData = "" rs.MoveNext Loop rs.Close Close #1
TRANSFER TO WORKBOOK
Private Sub Build_Data_Sheets_Click() Dim txtSplitTextFiles As String txtSplitTextFiles = "O:\Gorgon Data\Downstream_LNG POC\DWN Data Mgmt\CEDA Lite\Reports\" & NewFileName & ".txt"" Dim strWorksheetPathTable As String strWorksheetPathTable = "O:\GData\Downstream\DWN Data Mgmt\CEDAL\Reports\" & NewFileName & "..xls" Const LINES_PER_SHEET As Long = 1000000 Dim ResultStr As String Dim FileName As String Dim FileNum Dim Counter As Long, r As Long Dim arr() FileNum = FreeFile() Open txtSplitTextFiles For Input As #FileNum Counter = 0 r = 0 ReDim arr(1 To LINES_PER_SHEET, 1 To 1) Do While Not EOF(FileNum) Counter = Counter + 1 r = r + 1 Line Input #FileNum, ResultStr arr(r, 1) = ResultStr If r = LINES_PER_SHEET Then ArrayToSheet xlWB, arr r = 0 End If Loop If Counter Mod LINES_PER_SHEET > 0 Then ArrayToSheet xlWB, arr Close #FileNum
ARRAY TO SHEET SUB "CALLED"
Sub ArrayToSheet(wb As Workbook, ByRef arr) Dim r As Long r = UBound(arr, 1) With wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)) .Range("A1").Resize(r, 1).Value = arr End With ReDim arr(1 To r, 1 To 1) End Sub