оптимизировать код

[Hugo121]

Можно так (всё не делал, уже не интересно - думаю алгоритм понятен):

Dim sStr As String, sNum As String

Sub ТНВЭД__tt()
    Dim tm!: tm = Timer
    Dim lRow&, i&

    Application.ScreenUpdating = False

    lRow = [D3].End(xlDown).row

    With Cells(3, "C").Resize(lRow - 2, 1)
        .Clear
        .Font.Size = 7
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Value = "ОК"
        .Interior.ColorIndex = 4
    End With

    For i = 3 To lRow

        sStr = LCase(Cells(i, "K").Value)
        sNum = Left(Cells(i, "D").Value, 4)

        Select Case True
        Case chk1: NotOK i
        Case WorksheetFunction.And(InStr(sStr, "ткан") > 0, Left(Cells(i, "D"), 2) <> "62"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "трикот") > 0, InStr(LCase(Cells(i, "K")), "пальт") > 0, Left(Cells(i, "D"), 4) <> "6101"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "трикот") > 0, Cells(i, "P") <= 86, Left(Cells(i, "D"), 4) <> "6111"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "ткан") > 0, Cells(i, "P") <= 86, Left(Cells(i, "D"), 4) <> "6209"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "девоч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6101"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "женщ") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6101"): NotOK i
        Case chk8: NotOK i
            'Case WorksheetFunction.And(InStr(sStr, "мужчи") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6102"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мальч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6102"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "девоч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6103"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "женщ") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6103"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мужчи") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6104"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мальч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6104"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "девоч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6105"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "женщ") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6105"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мужчи") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6106"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мальч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6106"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "девоч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6107"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "женщ") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6107"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мужчи") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6108"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "мальч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6108"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "девоч") > 0, InStr(sStr, "ткан") > 0, Left(Cells(i, "D"), 4) = "6201"): NotOK i
        Case WorksheetFunction.And(InStr(sStr, "женщ") > 0, InStr(sStr, "ткан") > 0, Left(Cells(i, "D"), 4) = "6201"): NotOK i
        Case Cells(i, "E") = "": NotOK i
        End Select
    Next i

    Application.ScreenUpdating = True
    Debug.Print Timer - tm
End Sub

Function chk1() As Boolean
    If InStr(sStr, "трикота") > 0 Then
        If Left(sNum, 2) <> "61" Then
            chk1 = True
        End If
    End If
End Function

Function chk8() As Boolean
    If InStr(sStr, "мужчи") > 0 Then
        If InStr(sStr, "трикот") > 0 Then
            If sNum = "6102" Then
                chk8 = True
            End If
        End If
    End If
End Function


Sub NotOK(i&)
    With Cells(i, "C")
        .Value = "OШИБКА"
        .Interior.ColorIndex = 3
        .Font.Size = 5
    End With
End Sub

Как писал выше:

Ну и добавлять условия нет проблем - добавляем case и функцию с условиями.

[EducatedFool]

лично я заменил бы везде

WorksheetFunction.And(InStr(sStr, "мальч") > 0, InStr(sStr, "трикот") > 0, Left(Cells(i, "D"), 4) = "6104")

на что-то вроде этого:

sStr like "*мальч*трикот*" AND Cells(i, "D") like "6104*"

И короче по длине, и проще для восприятия

[Hugo121]

А если нужно проверять и на *трикот*мальч* ?

И опять же - зачем проверять Cells(i, "D") like "6104*", если первое условие неверно? Может там строк полмиллиона...

[Hugo121]

Перевёл на массивы (все условия прописывать лень):

Dim sStr As String, sNum As String, a()

Sub ТНВЭД_arr()
    Dim tm!: tm = Timer
    Dim lRow&, i&

    Application.ScreenUpdating = False

    lRow = [D3].End(xlDown).row

    With Cells(3, "C").Resize(lRow - 2, 9)
        With .Columns(1)
            .Clear
            .Font.Size = 7
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
            .Value = "ОК"
            .Interior.ColorIndex = 4
        End With
        a = .Value
    End With

    For i = 1 To lRow - 2

        sStr = LCase(a(i, 9))
        sNum = Left(a(i, 2), 4)

        Select Case True
        Case a(i, 3) = "": NotOK i
        Case chk1: NotOK i
            'тут добавить вызовов функций с условиями
        Case chk8: NotOK i
        End Select
    Next i

    Cells(3, "C").Resize(lRow - 2, 1).Value = a

    Application.ScreenUpdating = True
    Debug.Print Timer - tm
End Sub

Function chk1() As Boolean
    If InStr(sStr, "трикота") > 0 Then
        If Left(sNum, 2) <> "61" Then
            chk1 = True
        End If
    End If
End Function

Function chk8() As Boolean
    If InStr(sStr, "мужчи") > 0 Then
        If InStr(sStr, "трикот") > 0 Then
            If sNum = "6102" Then
                chk8 = True
            End If
        End If
    End If
End Function


Sub NotOK(i&)
    With Cells(i + 2, "C")
        .Interior.ColorIndex = 3
        .Font.Size = 5
    End With
    a(i, 1) = "OШИБКА"
End Sub

[nerv]

Text1 = LCase(Cells(i, "K").Value)
Text2 = Cells(i, "D").Value

Case WorksheetFunction.And(InStr(Text1, "ткан") > 0, Left(Cells(i, "D"), 2) <> "62")
Case WorksheetFunction.And(InStr(Text1, "мужчи") > 0, InStr(Text1, "трикот") > 0, Left(Cells(i, "D"), 4) = "6104")


ok = InValid(Text1, "ткан", Text2, "<>", "62")
ok = InValid(Text1, A("мужчи", "трикот"), Text2, "=", "6104")


Function InValid(ByVal Text1 As String, _
                 ByRef Arr As Variant, _
                 ByVal Text2 As String, _
                 ByVal Operation As String, _
                 ByVal Line2 As String) As Boolean
    Dim Elem As Variant
    
    For Each Elem In IIf(IsArray(Arr), Arr, Array(Arr))
        If Not InStr(Text1, Elem) Then
            Exit Function
        End If
    Next
    
    Select Case Operation
        Case "<>"
            If Left(Text2, Len(Line2)) = Line2 Then
                Exit Function
            End If
        Case "="
        If Left(Text2, Len(Line2)) <> Line2 Then
            Exit Function
        End If
    End Select
    
    InValid = True
End Function


' финт ушами
Function A(ParamArray param())
    A = param()
End Function