«системный ресурс превышен» при запуске функции

Question

У меня есть поле под названием «sku», которое однозначно идентифицирует продукты на столе, есть около 38 тыс. Продуктов. У меня есть «sku generator», который использует другие поля в таблице для создания SKU. Он работал отлично без проблем, пока я не начал выпускать SKU для большого количества продуктов. Я хотел бы запустить генератор и он остановится около 15000 и сказать: «System Resource превышена» и выделить следующий код в функции:

Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'")) 

у меня не было времени, чтобы полностью решить эту проблему, поэтому временное исправление для меня было разделение базы данных на две части и запуск генератора sku отдельно в обоих файлах. Теперь, когда у меня есть больше времени, я хочу выяснить, почему именно это зацикливается на этом номере, и если есть возможность исправить эту проблему (это сэкономит некоторое время с разделением файлов и последующим их группированием). У меня также есть проблема с тем, что время от времени происходит очень медленно, но я думаю, что это потому, что он обрабатывает так много, когда он работает. Вот функция

Option Compare Database 

Private Sub Command2_Click() 'Generate SKU 
Command2.Enabled = False: Command3.Enabled = False: Command2.Caption = "Generating ..." 
Me.RecordSource = "" 
CurrentDb.QueryDefs("ResetSKU").Execute 
Me.RecordSource = "loadsheet_4" 

Dim rs As Recordset, i As Long 
Set rs = Me.Recordset 
rs.MoveLast: rs.MoveFirst 

For i = 0 To rs.RecordCount - 1 
    rs.AbsolutePosition = i 
    rs.Edit 
    rs.Fields("sku") = SetSKU(rs) 
    rs.Update 
    DoEvents 
Next 
Command2.Enabled = True: Command3.Enabled = True: Command2.Caption = "Generate SKU" 
End Sub 


Public Function SetSKU(rs As Recordset) As String 
Dim TempStr As String, TempSKU As String, id As Integer, Found As Boolean, ColorFound As Variant 
id = 1: ColorFound = DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'") 

TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-" 
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-" 
TempStr = TempStr & "WR-" 
TempStr = TempStr & IIf(IsNull(ColorFound), "?", ColorFound) & "-4215-2-" 
TempStr = TempStr & rs.Fields("color_code") 

TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-") 
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'")) 
While Found = False 
    id = id + 1 
    TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-") 
    Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'")) 
Wend 
If id > 1 Then 
' MsgBox TempSKU 
End If 

SetSKU = TempSKU 
End Function 


Public Function Get1stLetters(Mystr As String, Optional twoLetters As Boolean = False) As String 
Dim i As Integer 
Get1stLetters = "" 

For i = 0 To UBound(Split(Mystr, " ")) 'ubound gets the number of the elements 
    If i = 0 And twoLetters Then 
     Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 2)) 
     GoTo continueFor 
    End If 
    Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 1)) 
continueFor: 
Next 
End Function 



Public Function ADDZeros(N As Integer, MAX As Integer) As String 
    Dim NL As Integer 
    NL = Len(CStr(N)) 
    If NL < MAX Then 
     ADDZeros = "0" & N 'StrDup(MAX - NL, "0") & N 
    Else: ADDZeros = N 
    End If 
End Function 

Примечание: Эта функция также вызывает другие функции, а также, что добавляет уникальный идентификатор к SKU, а также выводит первую букву каждого слова продукта

Также я бегу на 64-битный доступ.

Если вам нужна любая другая информация, сообщите мне, я не опубликовал другие функции, но при необходимости сообщите мне.

спасибо.

Answer 1

Я не уверен на 100%, как вы разделили базу данных на два файла и что вы используете генератор для обоих файлов. Однако у меня есть несколько предложений к функции, которую вы используете.

Я бы не передал объект recordet этой функции. Я предпочел бы передать идентификатор или уникальный идентификатор и создать набор записей в функции. Это может стать хорошим началом для эффективности.

Затем объявите все объекты явно, чтобы избежать неоднозначности библиотеки. rs Как DAO.Recordset. Постарайтесь использовать встроенные функции, например Nz().

Может Get1stLetters метод можно заменить простым Left() функции? Как насчет ADDZeros метод?

Использование DLookup может быть немного грязным, как насчет DCount вместо этого? Можно ли теперь использовать следующее?

Public Function SetSKU(unqID As Long) As String 
    Dim TempStr As String, TempSKU As String 
    Dim id As Integer 
    Dim ColorFound As String 
    Dim rs As DAO.Recordset 

    id = 1 

    Set rs = CurrentDB.OpenRecordset("SELECT single_color_name, make, model, year_dash, color_code " & _ 
            "FROM yourTableName WHERE uniqueColumn = " & unqID) 

    ColorFound = Nz(DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'"), "?") 

    TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-" 
    TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-" 
    TempStr = TempStr & "WR-" 
    TempStr = TempStr & ColorFound & "-4215-2-" 
    TempStr = TempStr & rs.Fields("color_code") 

    TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-") 

    While DCount("*", "Loadsheet", "[sku]='" & TempSKU & "'") <> 0 
     id = id + 1 
     TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-") 
    Wend 

    If id > 1 Then 
     'MsgBox TempSKU' 
    End If 

    Set rs = Nothing 

    SetSKU = TempSKU 
End Function