Run time error '3052'. File sharing lock count exceeded. Increase MaxLocksPerFile registry entry

Question

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()

DoCmd.SetWarnings False

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 & "]"
DoCmd.RunSQL SQL
SQL = "ALTER TABLE tmpdata ADD COLUMN id COUNTER"
DoCmd.RunSQL SQL
SQL = "SELECT count(*) as rowcount from [" & DTable & "]"
rs.Open SQL, cn
rowcount = rs!rowcount
rs.Close
tblcount = rowcount / 1000000 + 1
For i = 1 To tblcount
    SQL = "SELECT * into tmpdata" & i & " FROM tmpdata" & _
    " WHERE id<=1000000*" & i
    DoCmd.RunSQL SQL
    SQL = "DELETE * FROM tmpdata" & _
    " WHERE id<=1000000*" & i
    DoCmd.RunSQL SQL



DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel12, _
    TableName:="tmpdata" & i & "", FileName:=strWorksheetPathTable, _
    hasfieldnames:=True, _
    Range:="Data" & i & ""

DoCmd.DeleteObject acTable, "tmpdata" & i & ""

   Next i

DoCmd.DeleteObject acTable, "tmpdata"


DoCmd.SetWarnings True

MsgBox ("Report saved at the following location:                                                                 " & strWorksheetPathTable & "")


End Sub

Answer 1

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