"超出系统资源"运行功能时

时间:2014-12-15 17:44:57

标签: sql vba ms-access access-vba ms-access-2013

我有一个名为" sku"它独特地识别了桌面上的产品,大约有38k种产品。我有一个" sku发电机"它使用表中的其他字段来创建SKU。在我开始为大量产品生产SKU之前,它完美无缺。我会启动发电机,它会停在15,000左右,然后说'#34;系统资源超过"并在功能中突出显示以下代码:

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位访问上运行。

如果您需要任何其他信息让我知道,我没有发布其他功能,但如果需要请告诉我。

感谢。

1 个答案:

答案 0 :(得分:0)

我不是100%确定如何将数据库拆分为两个文件,并且您在两个文件上运行生成器。但是我对你正在使用的功能有一些建议。

我不会将记录集对象传递给此函数。我宁愿传递ID或唯一标识符,并在函数中生成记录集。这可能是提高效率的良好开端。

接下来,明确声明所有对象,以避免库歧义。 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