Ошибка времени выполнения '3052'. Счет блокировки обмена файлами превышен. Увеличьте запись реестра MaxLocksPerFile

Я уже давно работаю над этой базой данных и застрял в проблемах с паролями, которые у меня есть с базой данных, и это одна из них.Ошибка времени выполнения '3052'. Счет блокировки обмена файлами превышен. Увеличьте запись реестра MaxLocksPerFile

Этот код передает таблицу в excel, помещая каждую 1 000 000 записей на отдельный лист. Текущая таблица, которую я пытаюсь передать, имеет менее 1,5 миллиона записей и 7 полей.

Кодирование отлично работает до тех пор, пока оно не достигнет таблицы SQL Alter. В этот момент он выплевывает эту ошибку. Я уже увеличил dbMaxLocksPerFile до 20 миллионов, и это не помогло, и я в тупике.

Любая помощь, которую я мог бы получить на это было бы удивительно :)

FYI Это первый много программирования VBA я когда-либо делал, и я самоучка (Google научил), так что мой набор, и такие могут быть немного грязными. Код ниже:

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

источник

2014-10-24 Dane I

Я уверен, если кто-нибудь найдет это полезным, но мой метод обойти это, чтобы скопировать таблицу в 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 к Листу SUB "под названием"

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

источник

2015-01-22 01:17:48