Excel VBA：运行时错误 7：内存不足

Question

如果有人能帮助我解决我遇到的这个问题，我将不胜感激。基本上，VBA 是一种搜索功能，使用户能够从工作数据库中搜索工作的部分或全部名称。

但是，它会导致“运行时错误 7：内存不足”。这仅发生在我的 Macbook 上，不会发生在 Windows 计算机上。单击“调试”后，它把我带到了这行代码：

`If scd.Cells(i, j) Like "*" & Search & "*" Then

请帮忙！谢谢！

其余代码如下：

Option Compare Text
Sub SearchClientRecord()

Dim Search As String
Dim Finalrow As Integer
Dim SearchFinalRow As Integer
Dim i As Integer
Dim scs As Worksheet
Dim scd As Worksheet

Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")

scs.Range("C19:S1018").ClearContents

Search = scs.Range("C12")
Finalrow = scd.Range("D100000").End(xlUp).Row
SearchFinalRow = scs.Range("D100000").End(xlUp).Row

For j = 3 To 19
For i = 19 To Finalrow

If scd.Cells(i, j) Like "*" & Search & "*" Then
scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Next j
scs.Range("C19:S1018").Select
    scs.Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6 _
, 7), Header:=xlYes


Call Border
Columns("C:S").HorizontalAlignment = xlCenter

End Sub

Answer 1

@Alex P ，现在.find 效率并不高，例如：

Option Explicit
Option Compare Text

Sub SearchClientRecord()

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim Search As String
Dim Finalrow As Long
Dim SearchFinalRow As Long
Dim i&, j&
Dim scs As Worksheet
Dim scd As Worksheet
Dim DATA() As Variant
Dim Range_to_Copy As Range

Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")

With scd
    Finalrow = .Range("D100000").End(xlUp).Row
    DATA = .Range(.Cells(19, 3), .Cells(Finalrow, 19)).Value2
End With

With scs
    .Range("C19:S1018").ClearContents
    Search = .Range("C12").Value
    SearchFinalRow = .Range("D100000").End(xlUp).Row
End With


With scd
For j = 3 To 19
    For i = 19 To Finalrow
        If InStr(DATA(i, j), Search) > 0 Then
        'If scd.Cells(i, j) Like "*" & Search & "*" Then
            If Not Range_to_Copy Is Nothing Then
                Set Range_to_Copy = Union(Range_to_Copy, .Range(.Cells(i, 3), .Cells(i, 19)))
                'scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
                'scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
            Else
                Set Range_to_Copy = .Range(.Cells(i, 3), .Cells(i, 19))
            End If
    End If
    Next i
Next j
End With 'scd

Erase DATA

With scs

    Range_to_Copy.Copy _
    Destination:=.Range("C100000").End(xlUp).Offset(1, 0) '.PasteSpecial xlPasteFormulasAndNumberFormats

    .Range("C19:S1018").Select 'this line might be superflous
    .Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

End With

Call Border
Columns("C:S").HorizontalAlignment = xlCenter 'on wich worksheet ??

Set Range_to_Copy = Nothing
Set scs = Nothing
Set scd = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Answer 2

我在下面创建了一个名为“aLike”的替代函数。 在您的代码中，您可以这样使用它：If aLike("*" & Search & "*",scd.Cells(i, j)) Then 我不能保证它的工作方式完全相同，但我很想看看 Mac 是否能比“like”更好地处理这个功能。

Function aLike(asterixString As Variant, matchString As Variant, Optional MatchCaseBoolean As Boolean) As Boolean

    Dim aStr As Variant, mStr As Variant, aStrList As New Collection
    Dim i As Long, aPart As Variant, mPart As Variant, TempInt As Long, aStart As Boolean, aEnd As Boolean

    aStr = asterixString: mStr = matchString
    If Not MatchCaseBoolean Then aStr = StrConv(aStr, vbLowerCase): mStr = StrConv(mStr, vbLowerCase)
    ' Get rid of excess asterix's
    While InStr(aStr, "**") > 0
        aStr = Replace(aStr, "**", "*")
    Wend

    ' Deal with trivial case
    If aStr = mStr Then aLike = True: GoTo EndFunction
    If aStr = "*" Then aLike = True: GoTo EndFunction
    If Len(aStr) = 0 Then aLike = False: GoTo EndFunction

    ' Convert to list
    aStart = Left(aStr, 1) = "*": If aStart Then aStr = Right(aStr, Len(aStr) - 1)
    aEnd = Right(aStr, 1) = "*": If aEnd Then aStr = Left(aStr, Len(aStr) - 1)
    aLike_Parts aStr, aStrList

    ' Check beginning
    If Not aStart Then
        aPart = aStrList.Item(1)
        If Not (aPart = Left(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
    End If

    ' Check end
    If Not aEnd Then
        aPart = aStrList.Item(aStrList.Count)
        If Not (aPart = Right(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
    End If

    ' Check parts
    mPart = mStr
    For i = 1 To aStrList.Count
        aPart = aStrList.Item(i): TempInt = InStr(mPart, aPart)
        If TempInt = 0 Then aLike = False: GoTo EndFunction
        mPart = Right(mPart, Len(mPart) - TempInt - Len(aPart) + 1)
        If Len(mPart) = 0 And i < aStrList.Count Then aLike = False: GoTo EndFunction
    Next i
    aLike = True

EndFunction:
    Set aStrList = Nothing

End Function
Function aLike_Parts(Str As Variant, StrList As Collection) As Variant

    Dim Char As String, wPart As String

    For i = 1 To Len(Str)
        Char = Mid(Str, i, 1)
        If Char = "*" Then
            StrList.Add wPart: wPart = ""
            Else
            wPart = wPart & Char
        End If
    Next i
    If Len(wPart) > 0 Then StrList.Add wPart

End Function

祝你好运！