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

我創建一個名爲「相似」下面的複用功能。 在你的代碼中，你會用它來說：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 

祝你好運！

Answer 2

@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