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が処理できるかどうかは興味があります。

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 

Good Luck！

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