Sub Start()  'Пробная процедура'
      Dim a As Range
      Set a = Range("A1:A7") 'Обрабатываемый диапазон'
      Call SearchID(a)
End Sub

Sub SearchID(diap As Range)
      Dim BaseDiap As Range, x As Range, c As Range
        
      Set BaseDiap = Range("C1:C4")  'Диапазон с исходными данными'
      For Each x In diap
          Set c = BaseDiap.Find(What:=x.Value, LookIn:=xlValues)
          If Not (c Is Nothing) Then
              'Если что-то нашли, то копируем значение из соседнего столбца'
              Cells(x.Row, x.Column + 1).Value = Cells(c.Row, c.Column + 1).Value
          End If
      Next x
End Sub

Worksheets("Общий").Range(Cells(1, 1), Cells(a, 1))

Sub СортировкаZ3массив()

Dim K1(999999) As String 'Массив
Dim K2(999999) As String 'Массив
Dim K3(999999) As Integer 'Массив
Dim nss As Long
Dim retval As Integer
Dim d1 As Date, d2 As Date, Время As String

xx = InputBox("В какой столбик писать результат?")
d1 = Time

nss = 2
Do While Worksheets("Сортировка").Range("B" & nss).Value <> "" 'определить количество строк в Сортировка
nss = nss + 1
Loop
nss = nss - 1
'MsgBox nss

nso = 2
Do While Worksheets("Общий").Range("A" & nso).Value <> "" 'определить количество строк в Общий
nso = nso + 1
Loop
nso = nso - 1
'MsgBox nso

         For q2 = 2 To nss
             K2(q2) = Worksheets("Сортировка").Cells(q2, 2) 'запомнить артикул в Сортировка
         Next
         For q3 = 2 To nss
             'MsgBox q3
             K3(q3) = Worksheets("Сортировка").Cells(q3, 3) 'запомнить количество в Сортировка
             'MsgBox K3(q3)
         Next
         For q1 = 2 To nso
             K1(q1) = Worksheets("Общий").Cells(q1, 1) 'запомнить артикул в Общем
         Next

         For i = 2 To nss
             If K3(i) > 0 Then 'если количество больше 0
             
                  
                ''''''''''''''''''''Worksheets("Общий").Range("A" & nso).Select
                 
                  
                     If Worksheets("Общий").Cells.Find(What:=K2(i), LookAt:=xlWhole) Is Nothing Then   'если не нашлось
                         Worksheets("Сортировка").Cells(i, 2).Interior.Color = VBA.RGB(255, 0, 0)
                     Else
                         R = Worksheets("Общий").Cells.Find(What:=K2(i), LookAt:=xlWhole).Row
                         Worksheets("Общий").Cells(R, CDbl(xx)).Value = K3(i)
                     End If
             End If
         Next
          
Beep
d2 = Time
Время = MsgBox((DateDiff("n", d1, d2) \ 60 & " часов " & DateDiff("n", d1, d2) Mod 60 & " минут " & DateDiff("s", d1, d2) Mod 60 & " секунд"), 0, "Затрачено:")
End Sub

Sub СортировкаZ2()

Dim nss As Long
xx = InputBox("В какой столбик писать результат?")
y = InputBox("С какой строки начинать?")

MsgBox Time
nss = 2
Do While Worksheets("Сортировка").Range("B" & nss).Value <> ""
nss = nss + 1
Loop
MsgBox Time
         For i = 2 To nss - 1
             If Worksheets("Сортировка").Range("C" & i) > 0 Then
                 zz = Worksheets("Сортировка").Range("B" & i)
                     If Worksheets("Общий").Cells.Find(What:=zz, LookAt:=xlWhole) Is Nothing Then
                         Worksheets("Сортировка").Cells(i, 2).Interior.Color = VBA.RGB(255, 0, 0)
                     Else
                         R = Worksheets("Общий").Cells.Find(What:=zz, LookAt:=xlWhole).Row
                         zz = Worksheets("Сортировка").Range("C" & i)
                         Worksheets("Общий").Cells(R, CDbl(xx)).Value = zz
                     End If
             End If
         Next
Beep
MsgBox Time
End Sub

=VLOOKUP(A2;Сортировка!A:B;2;0)

Sub СортировкаZ3массив22()
Dim x, i&, r As Range
Dim tm#: tm = Timer
With Sheets("Общий")
       x = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Value
End With
With Sheets("Сортировка").Columns(1)
       For i = 1 To UBound(x)
           Set r = .Find(x(i, 1), LookAt:=xlWhole)
           If r Is Nothing Then x(i, 1) = "" Else x(i, 1) = r(1, 2)
       Next i
End With
Sheets("Общий").Range("B1").Resize(i - 1).Value = x
MsgBox Timer - tm
End Sub

If r Is Nothing Then x(i, 1) = "zzz" Else r(1)(1, 2) = x(i, 1)

Sub ertert()
Dim tm#: tm = Timer
Dim x, y, rez(), i&, j&, bu As Boolean
Dim ubx&, lbx&

With Sheets("Сортировка")    'где ищем. Данные д.б. отсортированы по Коду
     'берем 2 столбца
     x = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With

With Sheets("Общий")    'что ищем, сортировать необязательно
     y = .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).Value
End With
ReDim rez(1 To UBound(y), 1 To 1)

For i = 1 To UBound(y)
     lbx = 1: ubx = UBound(x)
     Do
         bu = 0: j = (lbx + ubx) \ 2
         Select Case y(i, 1)
             Case Is > x(j, 1): lbx = j + 1
             Case Is < x(j, 1): ubx = j - 1
             Case Is = x(j, 1): bu = 1: Exit Do
         End Select
     Loop Until ubx < lbx
     'x(j, 2) - возвращаем значение из 2-го столбца листа Сортировка
     If bu Then rez(i, 1) = x(j, 2)
Next i

Sheets("Общий").Range("B2").Resize(i - 1).Value = rez()
MsgBox Timer - tm
End Sub