Question

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

此代码将表格转移到Excel中，将每1,000,000条记录放在一张单独的表格中。我试图转移的当前表只有不到150万条记录和7个字段。

编码工作正常，直到它到达Alter Table SQL。此时它会吐出这个错误。我已经将dbMaxLocksPerFile增加到了2000万，这没有帮助，我很难过。

我能得到的任何帮助都会令人惊叹：）

仅供参考我这是我做过的第一批VBA节目，并且是自学成才（谷歌教授），所以我的出发也可能有点混乱。代码如下：

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

我希望你能得到答案，但你也可以尝试以下步骤

打开空访问应用程序。
选择文件＆gt;＆gt;开放＆GT;＆GT;浏览并选择数据库文件。
点击浏览窗口中的“打开”按钮下拉列表。
选择＆＃34; Open Exclusive＆＃34;选项。

数据库文件将以解锁状态打开。现在执行脚本，它应该没有任何错误。

Answer 2

答案在这里：

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

实际上仔细观察，对我来说这是一个更好的答案

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

将此代码放入脚本中：DAO.DBEngine.SetOption dbmaxlocksperfile，15000

但之后又回到9500，显然这很重要

Answer 3

我不确定是否有人会发现这有用，但我解决此问题的方法是将表格复制到txt文件，然后将此处的1,000,000条记录一次复制到单独的Excel表格中。

出口至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

转移到工作簿

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注册表项

3 个答案: