Блог

Контекст

Я использую код и пытаюсь внести небольшие изменения в функцию с IsInArray(custom) на Instr , но получаю ошибку компиляции.

Я просто пытаюсь изменить

 "If IsInArray(Worksheets("Sheet1").Cells(i, 11).Value, vAllSheet2Values)"
 

Для

  If InStr(Worksheets("Sheet1").Cells(i, 11).Value, vAllSheet2Values)
 

Но это выдает ошибку компиляции. Разве я не могу просто изменить функцию? Если нет, то как я могу это сделать?

Код

             Sub remDup()
            Dim LR As Long, LRSheet2 As Long, i As Long, a As Long
            Dim vAllSheet2Values() As Variant

            LRSheet2 = Worksheets("Sheet2").Cells(Rows.Count, 3).End(xlUp).Row
            LR = Worksheets("Sheet1").Cells(Rows.Count, 11).End(xlUp).Row
            a = 2

            For i = 1 To LRSheet2 
                ReDim Preserve vAllSheet2Values(i)
                vAllSheet2Values(i) = Worksheets("Sheet2").Cells(i, 3).Value
            Next i

            For i = LR To 1 Step -1
                If IsInArray(Worksheets("Sheet1").Cells(i, 11).Value, vAllSheet2Values) Then
                    Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet3").Rows(a)
                    Worksheets("Sheet1").Rows(i).Delete
                    a = a   1
                End If
            Next i
            End Sub

            Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
                IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
            End Function
 

В зависимости от размера LR и LRSheet2 выполнение этого кода может занять некоторое время. Это один из способов InStr() сравнения ячеек в каждом столбце.

Я определил ваши листы, определил Rows.Count части LR и LRSheet2 и включил секунду For Loop для циклического перебора каждого элемента в вашем vAllSheet2Values() массиве.

 Option Explicit
Sub remDup()
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Sheet3")
    Dim LR As Long, LRSheet2 As Long, i As Long, a As Long
    Dim vAllSheet2Values() As String, sheet2Val As Variant

    LRSheet2 = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row
    LR = ws1.Cells(ws1.Rows.Count, 11).End(xlUp).Row
    a = 2

    For i = 1 To LRSheet2
        ReDim Preserve vAllSheet2Values(i)
        If ws2.Cells(i, 3).Value <> "" Then _
            vAllSheet2Values(i) = CStr(ws2.Cells(i, 3).Value) 'Don't add blanks
        Debug.Print ws2.Cells(i, 3).Value
    Next i

    For i = LR To 1 Step -1
        If ws1.Cells(i, 11).Value = "" Then GoTo SkipTheRest 'Skip blanks
        For Each sheet2Val In vAllSheet2Values
            If InStr(sheet2Val, CStr(ws1.Cells(i, 11).Value)) <> 0 Then
                ws1.Rows(i).Copy ws3.Rows(a)
                ws1.Rows(i).Delete
                a = a   1
                GoTo SkipTheRest 'Match found, skip the rest
            End If
        Next sheet2Val
        'You can include the following statement if you want to catch when there
        'isn't a match on Sheet1
        'MsgBox "No match found for " amp; ws1.Cells(i, 11).Value, vbOKOnly, "No Match"
SkipTheRest:
    Next i
End Sub