Поиск схожих значений в двух столбцах и перенос из первого на другой лист

Sub BlackInWhite()
Dim arrW(), arrB(), arrR(), i&, j&, c&
   With ActiveSheet
      arrW = .Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Value
      arrB = .Columns("C:C").SpecialCells(xlCellTypeConstants, 1).Value
      ReDim arrR(1 To UBound(arrB), 1 To 1):   c = 0
         For i = LBound(arrB, 1) To UBound(arrB, 1)
            For j = LBound(arrW, 1) To UBound(arrW, 1)
               If "*" & CStr(arrW(j, 1)) Like "*" & CStr(arrB(i, 1)) Then
                  c = c + 1: arrR(c, 1) = arrW(j, 1): Exit For
               End If
            Next 'j
         Next 'i
      Application.ScreenUpdating = False
      .[h2].Resize(UBound(arrR), 1).Value = arrR
      Application.ScreenUpdating = True
   End With
End Sub

Sub Кнопка3_Щелчок()
Dim shSheet_1 As Excel.Worksheet, shSheet_2 As Excel.Worksheet
Dim rFind As Excel.Range, cC As Range, mARR(), i&
   Set shSheet_1 = Sheets("Лист1"):  Set shSheet_2 = Worksheets("Лист2")
   With shSheet_1
      ReDim mARR(1 To .Columns("c:c").SpecialCells(xlCellTypeConstants, 1).Count, 1 To 1)
      For Each cC In .Columns("c:c").SpecialCells(xlCellTypeConstants, 1).Cells
         Set rFind = .Columns("a:a").Find(cC.Value, , , xlPart, , False)
            If Not rFind Is Nothing Then i = i + 1:  mARR(i, 1) = rFind.Value
      Next
   End With
   With shSheet_2
      .Cells.Delete: .[a2].Resize(UBound(mARR, 1), 1).Value = mARR: .Columns.AutoFit
   End With
End Sub