[a_axe]

забивает ячейку всем подряд из листа "коды" »

не всем подряд, а только если находит соответствие, и это происходит строго в рамках указанного вами алгоритма:

Если нашлось совпадение в 2 столбце, но не нашлось совпадения в 1 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. »

В вашем примере в первой строчке обязано появится красное значение 3100, по той причине что в кодах значение "3100" указано рядом с "с3", которое замыкает ячейку второго столбца первой строки листа "Данные". Это та самая указанная вами ситуация: нашлось совпадение в 2 столбце, но не нашлось совпадения в 1 столбце, надо дописать в первый столбец значение из массива находящееся во второй размерности и закрасить его красным цветом. В вашем листе "Итоги" это значение почему-то не вставлено, вероятно требуется еще обдумать алгоритм.

Надо именно в текущей ячейке. »

Самый простой вариант - создать дополнительный столбец, обработать значения в нем, а затем удалить весь первый столбец. Код приблизительно такой:

Скрытый текст

Код:

Sub cehout_3()
    Application.ScreenUpdating = False
    massceh = Sheets("коды").Cells(1, 1).CurrentRegion.Value
    ActiveSheet.Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveSheet.Cells(1, 1).CurrentRegion.AutoFill Destination:=ActiveSheet.Cells(1, 1).CurrentRegion.Resize(ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count, 2), Type:=xlFillCopy
    'arrlist = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown))
    
    '    Ncolumn1 = Columns(1)
    '    Ncolumn2 = Columns(2)
    For i = 1 To Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown)).Rows.Count
        For j = LBound(massceh) To UBound(massceh)
            If InStr(1, Cells(i, 3), massceh(j, 1)) > 0 Then
                If InStr(Cells(i, 1), massceh(j, 2)) > 0 Then
                    intFoundPosition = InStr(1, Cells(i, 1), massceh(j, 2))
                    Do While intFoundPosition > 0
                        Cells(i, 2).Characters(intFoundPosition, Len(massceh(j, 2))).Font.Color = -11489280 'зелёный
                        intFoundPosition = InStr(intFoundPosition + 1, Cells(i, 2), massceh(j, 2), vbTextCompare)
                    Loop
                Else
                    Cells(i, 2).Value = Cells(i, 2).Value & "-" & massceh(j, 2)
                    Cells(i, 2).Characters(Len(Cells(i, 1).Value) + 1, Len(Cells(i, 2).Value) - Len(Cells(i, 1).Value)).Font.ColorIndex = 3
                End If
            End If
        Next j
    Next i
    ActiveSheet.Columns(1).Delete
    Application.ScreenUpdating = True
End Sub