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

问题

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

回答1:

i hope you got the answer, but you can try the below steps also

Open empty access application.
Select File >> Open>> Browse and select the Database file.
Click dropdown on Open button in the browse window.
Select "Open Exclusive" option.

The database file will be opened in unlocked state. Now execute the script, it should work without any error.

回答2:

Answer is here:

http://www.anysitesupport.com/access-maxlocksperfile-file-sharing-lock-count-exceeded/

Actually looking at it closer, this is a better answer for me

http://support2.microsoft.com/kb/815281

put this code in your script: DAO.DBEngine.SetOption dbmaxlocksperfile,15000

But then set back to 9500 after, apparently it is important

回答3:

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

来源：https://stackoverflow.com/questions/26542653/run-time-error-3052-file-sharing-lock-count-exceeded-increase-maxlocksperfil

标签

mysql

excel

vba

access-vba

transfer