Excel VBA：运行时错误7：内存不足
如果有人能帮我解决我遇到的这个问题，我将不胜感激。 基本上，VBA是一个searchfunction，使用户能够从作业数据库中search部分或全部作业名称。
但是，它会导致“运行时错误7：内存不足”。 这只发生在我的Macbook上，并不会在Windows电脑上发生。 点击“debugging”，它将我带到这行代码：
`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
我在下面创build了一个名为“aLike”的替代函数。 在你的代码中，你会用它来说： If aLike("*" & Search & "*",scd.Cells(i, j)) Then我不能保证它的工作方式完全一样，但我会感兴趣看看Mac能否比“like”更好地处理这个function。
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
祝你好运！
.find 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