=ИНДЕКС($B$3:$P$3;ОСТАТ(СТРОКА()-СТРОКА($18:$18);B$10)+1)

=ИНДЕКС($B$4:$P$4;ОСТАТ(ЦЕЛОЕ((СТРОКА()-СТРОКА($18:$18))/B$10);C$10)+1)

=ИНДЕКС($B$5:$P$5;ОСТАТ(ЦЕЛОЕ((СТРОКА()-СТРОКА($18:$18))/C$10/B$10);D$10)+1)

Function СистемаСчисления(Число As String, Optional СистемаИз As Byte = 10, Optional СистемаВ As Byte = 10)
    Dim d As Double
    Dim i As Integer
    Dim s As String
    Dim c As Variant
    Dim z As Long
    Dim k As Byte
    
    c = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    
    If Число = "0" Then
       СистемаСчисления = "0"
    Else
        'преобразование цифры в число
        d = 0
        For i = 1 To Len(Число)
            s = Mid(UCase(Число), i, 1)
            
            k = 0
            Do
                If s = c(k) Then
                    d = d + k * СистемаИз ^ (Len(Число) - i)
                    Exit Do
                End If
                k = k + 1
                If k > UBound(c) Then Exit Do
            Loop
        Next
        
        'преобразование числа в цифру
        s = ""
        For i = Val(Log(d) / Log(СистемаВ)) To 0 Step -1
            z = СистемаВ ^ i
            k = Val(d / z)
            
            s = s & c(k)
            d = d - k * z
        Next
        
        СистемаСчисления = s
    End If
End Function

    Dim iYvvod As Long
    Dim iYcorr As Long
    Dim shVvod As Worksheet
    Dim shCorr As Worksheet
    Dim shResu As Worksheet
    Dim arrResu() As Variant
    
    Set shVvod = Sheets("вводные данные")
    Set shCorr = Sheets("таблица соответствия")
    Set shResu = Sheets("результат")
        
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
     
    With shVvod.Columns(1)
        ReDim arrResu(.Cells(Rows.Count).End(xlUp).Row - 1, 1)
        
        For iYvvod = 1 To .Cells(Rows.Count).End(xlUp).Row
            arrResu(iYvvod - 1, 0) = .Cells(iYvvod).Value
            
            For iYcorr = 1 To shCorr.Cells(Rows.Count, 1).End(xlUp).Row
                If InStr(arrResu(iYvvod - 1, 0), shCorr.Cells(iYcorr, 1).Text) > 0 Then
                     arrResu(iYvvod - 1, 1) = arrResu(iYvvod - 1, 1) & IIf(arrResu(iYvvod - 1, 1) = "", "", ", ") & shCorr.Cells(iYcorr, 2).Text
                End If
            Next iYcorr
            
        Next iYvvod
    End With
     
    With shResu
        .Cells.Clear
        .Range(.Cells(1, 1), .Cells(UBound(arrResu, 1) + 1, 2)) = arrResu()
    End With

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Cells.Count > 1 Then Exit Sub
        If Intersect(.Cells, Range("G3:G120")) Is Nothing Then Exit Sub
        If .Value = "" Then Exit Sub
        
        Dim iY As Integer
        Dim i As Integer
               
        If WorksheetFunction.CountIfs(Columns(3), .Value) > 0 Then
            iY = WorksheetFunction.Match(.Value, Columns(3), 0)
            i = Cells(iY + 1, 3).Value
            Range(Cells(iY + 1, 2), Cells(iY + 1, 120)).Copy Cells(iY, 2)
            Cells(iY, 3).Value = i
            
        End If
    End With
End Sub

If (.Value / 6 - .Value \ 6) > 0.0000000001 Then

 With Target.Offset(, -1)  

    With Target
        If .Value / 6 <> .Value \ 6 Then
            .Select '<------------------------------------------
            Call MsgBox("Не кратно 6.", vbCritical)
        End If
    End With

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Intersect(Target, Range("H11:H1048576")) Is Nothing Then Exit Sub
    
    With Target
        If .Value / 6 <> .Value \ 6 Then
            Call MsgBox("Не кратно 6.", vbCritical)
        End If
    End With
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheets("Лист1").Activate
End Sub

Private Sub Worksheet_Activate()
    
    Dim c As Range
    
    With ActiveSheet
        .Cells.Clear
        
        For Each c In Sheets(1).UsedRange
            If c.Font.Bold Then
                .Range(c.Address).Value = 1
            Else
                .Range(c.Address).Value = 0
            End If
        Next
        
    End With
   
End Sub

Option Explicit

Sub ПроверкаЖурналаЗаявок()
 
    Dim rngX As Range
    Dim c As Range
    Dim i As Integer
    Dim iM As Integer
    Dim iP As Integer
    Dim iMandP As Integer
    Dim colF As Double
    Dim j As Integer
    Dim bM As Boolean
    Dim bP As Boolean
     
Set rngX = Selection
Set c = rngX.Cells
 
    i = 0
    iM = 0
    iP = 0
    iMandP = 0
     
    For Each c In rngX
        If c.Value <> "" Then
            i = i + 1
            
            bM = False
            bP = False
            With c
                For j = 1 To Len(c.Text)
                   Select Case .Characters(Start:=j, Length:=1).Font.Color
                   Case 1842204, 1118481, 0
                    bM = True
                   Case 255, 204
                    bP = True
                   End Select
                Next j
            End With
            
            If bM Then iM = iM + 1
            If bP Then iP = iP + 1
            If bM And bP Then iMandP = iMandP + 1
        End If
    Next c
     
    Debug.Print "всего "; i
    Debug.Print "выход мех."; iM
    Debug.Print "простоев"; iP
     
    i = i - iM - iP + iMandP
     
    Debug.Print "аварийка"; i
 
End Sub