运行时错误“ 3052”。超出文件共享锁定计数。增加MaxLocksPerFile注册表项 [英] Run time error '3052'. File sharing lock count exceeded. Increase MaxLocksPerFile registry entry

问题描述

我已经在这个数据库上工作了一段时间，并且一直困扰着我在数据库中遇到的几个问题，这就是其中之一。

此代码将表格转移到excel中，将每1,000,000条记录放在单独的工作表中。我正在尝试传输的当前表具有将近150万个记录和7个字段。

编码工作正常，直到遇到Alter Table SQL。此时，它会吐出此错误。我已经将dbMaxLocksPerFile增加到2000万，但这并没有帮助，我感到很困惑。

我能提供的任何帮助都很棒：）

  Private Sub EXPORT_TO_EXCEL_Click（）
 
 DoCmd.SetWarnings False 
 
 DAO.DBEngine.SetOption dbMaxLocksPerFile，20000000'那就是2000万！ 
 
'DTable是文件名，由用户在较早的编码下由公共字符串
 
输入。调用CreateNewFolder（ O：\文件夹位置\& ; DTable&）
 
 Dim strWorksheetPathTable as String 
 
'----设置文件路径
 strWorksheetPathTable = O：\文件夹位置 
 strWorksheetPathTable = strWorksheetPathTable& 和表和表 \和表和表 .xlsb 
 
 
'----访问中的数据表，然后导出这些较小的表（如果记录超过1,000,000，则拆分）
 
变小ADODB.Recordset 
 Dim cn作为新的ADODB.Connection 
 Set cn = CurrentProject.Connection 
 Dim行数只要
 Dim tblcount作为整数
 Dim我作为整数
 Dim tblx作为字符串
 Dim dbsDatas作为DAO.Database 
设置dbsDatas = CurrentDb 
 
 
 SQL = SELECT * INTO tmpdata FROM [&表和表] 
 DoCmd.RunSQL SQL 
 SQL =更改表tmpdata添加列ID计数器 
 DoCmd.RunSQL SQL 
 SQL =从[ &表和表] 
 rs。打开SQL，cn 
 rowcount = rs！rowcount 
 rs.Close 
 tblcount =行数/ 1000000 + 1 
对于i = 1要tblcount 
 SQL = SELECT * into tmpdata&我和 FROM tmpdata和_ 
 WHERE id< = 1000000 *& i 
 DoCmd.RunSQL SQL 
 SQL = DELETE * FROM tmpdata& _ 
 WHERE id< = 1000000 *& i 
 DoCmd.RunSQL SQL 
 
 
 
 DoCmd.TransferSpreadsheet传输类型：= acExport，_ 
电子表格类型：= acSpreadsheetTypeExcel12，_ 
 TableName： = tmpdata&我和，FileName：= strWorksheetPathTable，_ 
 hasfieldnames：= True，_ 
范围：= Data&我和 
 
 DoCmd.DeleteObject acTable， tmpdata&我和 
 
接下来的i 
 
 DoCmd.DeleteObject acTable， tmpdata 
 
 
 DoCmd.SetWarnings True 
 
 MsgBox（报告保存在以下位置：& strWorksheetPathTable&）
 
 
结束子
  

解决方案

我不确定是否有人会对此有所帮助，但是我解决这个问题的方法是将表复制到 txt 文件，然后一次从此处将1,000,000条记录复制到单独的Excel工作表中。

导出到TXT

  Private Sub EXPORT_TO_TEXT_FILE_Click（）
 Dim txtFile作为字符串，rs作为DAO.Recordset，j作为整数，strFld作为字符串， strData作为字符串
 txtFile = O：\GData\下游\DWN数据管理\CEDAL\报表\&新文件名&  .txt 
设置rs = CurrentDb.OpenRecordset（& NewFileName&）
对于j = 0到rs.Fields.Count-1 
 strFld = strFld& vbTab& rs（j）。名称
下一个
打开txtFile输出为＃1 
打印＃1，Mid（strFld，2）
 
直到rs.EOF 
 
对于j = 0到rs.Fields.Count-1 
 strData = strData& vbTab& rs（j）
下一个
打印＃1，Mid（strData，2）
 
 strData = 
 rs.MoveNext 
循环
 rs.Close 
 Close＃1 
  

转移到工作簿

  Private Sub Build_Data_Sheets_Click（）
 
 Dim txtSplitTextFiles As String 
 txtSplitTextFiles = O：\Gorgon Data\Downstream_LNG POC\DWN Data Mgmt\CEDA Lite\Reports\&新文件名&  .txt 
 
 Dim strWorksheetPathTable as String 
 strWorksheetPathTable = O：\GData\下游\DWN数据管理\CEDAL\Reports\& NewFileName& ; ..xls 
 
 Const LINES_PER_SHEET as Long = 1000000 
 Dim ResultStr as String 
 Dim FileName As String 
 Dim FileNum 
 Dim Counter Long ，r只要Long 
 
 Dim arr（）
 
 
 FileNum = FreeFile（）
打开txtSplitTextFiles输入为#FileNum 
 
计数器= 0 
r = 0 
 
 ReDim arr（1到LINES_PER_SHEET，1到1）
 
不使用EOF（FileNum）
 
计数器=计数器+ 1 
r = r + 1 
行输入#FileNum，ResultStr 
 arr（r，1）= ResultStr 
 
 
 
如果r = LINES_PER_SHEET，则
 ArrayToSheet xlWB，arr 
r = 0 
 
 End如果
循环
 
如果Counter Mod LINES_PER_SHEET > 0然后ArrayToSheet xlWB，arr 
 
关闭#FileNum 
  

要对子目录进行子目录

  Sub ArrayToSheet（wb as Workbook，ByRef arr）
 Dim r As Long 
r = UBound（arr，1）
和wb.Sheets。 Add（after：= wb.Sheets（wb.Sheets.Count））
 .Range（ A1）。Resize（r，1）.Value = arr 
结尾为
 ReDim arr （1对r，1对1）
结束子
  

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

解决方案

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

这篇关于运行时错误“ 3052”。超出文件共享锁定计数。增加MaxLocksPerFile注册表项的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！