Option Explicit

'Для старта.
Sub Start()
    PrintWord GetDirection() + 1
End Sub
'Для смены направления перевода.
Sub ChangeDirection()
    With Sheets("Проверка").Range("E1")
        Application.EnableEvents = False
        If IsEmpty(.Value) Then
            .Value = "eng"
        Else
            .Value = Empty
        End If
        Application.EnableEvents = True
    End With
End Sub
Function GetDirection() As Byte
    Dim direction As Byte
    With Sheets("Проверка").Range("E1")
        If IsEmpty(.Value) Then
            direction = 0
        Else
            direction = 1
        End If
    End With
    GetDirection = direction
End Function

Function GetArr() As Variant
    Dim arr As Variant
    Dim y As Long
    With Sheets("Словарь")
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    GetArr = arr
End Function

Sub PrintWord(ByVal x As Byte)
    Dim arr As Variant
    Dim y As Long
    arr = GetArr()
    If x < 1 Or x > UBound(arr, 2) Then x = 1
    
    With Sheets("Проверка")
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = y + 1
        If y > 30 Then Exit Sub
        Dim r As Range
        Set r = .Cells(y, 1)
        Randomize
        y = Rnd() * (UBound(arr, 1) - 1) + 1
        If y < 2 Then y = UBound(arr, 1)
        r.Value = arr(y, x)
        .Select
        Application.EnableEvents = False
        r.Cells(1, 2).Select
        Application.EnableEvents = True
    End With
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Column = 2 Then
            If Target.Row <= 30 Then
                If Target.Value <> "" Then
                    Dim arr As Variant
                    arr = GetArr()
                    Dim d As Byte
                    d = GetDirection()
                    Dim s1 As String
                    Dim s2 As String
                    With Cells(Target.Row, Target.Column - 1)
                        s1 = LCase(.Cells(1, 1 + d).Value)
                        s2 = LCase(.Cells(1, 2 - d).Value)
                    End With
                    Dim y As Long
                    Dim b As Boolean
                    b = False
                    For y = 1 To UBound(arr, 1)
                        If LCase(arr(y, 1)) = s1 Then
                            If LCase(arr(y, 2)) = s2 Then
                                b = True
                            End If
                            Exit For
                        End If
                    Next
                    
                    If b Then
                        PrintWord d + 1
                    Else
                        Application.EnableEvents = False
                        Target.Value = Empty
                        Target.Select
                        Application.EnableEvents = True
                    End If
                
                End If
            End If
        End If
    End If
End Sub

=Лист2!C2       =ПРАВСИМВ(B2;3)

=СМЕЩ(Лист2!$C$2:$C$1048576;0;0;СЧЁТЗ(Лист2!$C$2:$C$1048576))

ActiveWorkbook.Close

Option Explicit
'Версия 5.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), DateValue(arr(yM + 1, x) & " " & arr(yM, 6)), DateValue(arr(yM + 1, e) & " " & arr(yM, 6)))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(Format(v(2), "dd.mm.yy") & IIf(v(2) = v(3), "", " - " & Format(v(3), "dd.mm.yy")), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function

=ИНДЕКС(Лист1!$D$1:$D$2000;2000-НАИБОЛЬШИЙ((Лист1!$B$1:$B$2000=B6)*(2000-СТРОКА(Лист1!$B$1:$B$2000));СТРОКА(1:1)))

Sub SelectionGroup()
    Selection.ClearOutline
    Dim y As Long
    For y = Selection.Row To Selection.Row + Selection.Rows.Count - 1
        Rows(y).OutlineLevel = Cells(y, 1).IndentLevel + 1
    Next
End Sub

Application.Run "'" & ThisWorkbook.Name & "'!'" & curCell.Value    

Sub test()
    Dim i As Byte
    For i = 1 To 3
        If Cells(i, 1).Value = "ГГКц" Then ГГКц
    Next
End Sub

Sub ГГКц()
    Debug.Print Now, "ГГКц"
End Sub

If curCell.Value = "ГГКц" Then ГГКц

KM.Add KM.Count, CStr(i.Value)

KM.Item(CStr(i.Value)) = 0

Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Items())

Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Keys())

Range("A1").Resize(1,Ubound(arr)-Lbound(arr)+1) = arr

Sub СборкаМатериалов220921()
    Dim KM As Object
    Set KM = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
    Set arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each i In arr
        KM.Add KM.Count, CStr(i.Value)
    Next i
    On Error GoTo 0
     
    Range("A1").Resize(KM.Count, 1) = Application.Transpose(KM.Items())
End Sub

Option Explicit
'Версия 4.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(v(2) & IIf(v(2) = v(3), "", " - " & v(3)), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function

If ActiveSheet.Shapes.Count > 0 Then ActiveSheet.Shapes(1).Delete

=СЧЁТЕСЛИМН(новая!$A:$A;$A:$A;новая!$B:$B;$B:$B;новая!$D:$D;$D:$D;новая!$E:$E;$E:$E;новая!$F:$F;$F:$F;новая!$G:$G;$G:$G)

Макросом

Sub Сравнить()
    Dim y As Long
    Dim r As Range
    
    'Задаём ячейку на листе новая, в которую будем вносить.
    With Sheets("новая")
        Set r = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
    End With
    
    With Sheets("старая") 'На листе старая
        y = .Cells(.Rows.Count, 1).End(xlUp).Row    'ищем номер последней строки
        If y < 3 Then Exit Sub  'Если строк мало, выходим из макроса
        With .Range(.Cells(1, "H"), .Cells(y, "H")) 'в столбец H
            .FormulaR1C1 = "=COUNTIFS(новая!C1,C1,новая!C2,C2,новая!C4,C4,новая!C5,C5,новая!C6,C6,новая!C7,C7)" 'вписываем формулу, считающую, сколько раз встречается строка
            .Calculate  'вычисляем внесённую формулу. На случай, если вычисления отключены.
            Dim arr As Variant
            arr = .Cells    'Результат запоминаем в массив
        End With
         
        Dim brr As Variant
        For y = 2 To UBound(arr, 1) 'Перебираем строки полученного массива
            If arr(y, 1) = 0 Then   'Если значение 0, если строки нет на листе новая
                brr = .Cells(y, 1).Resize(1, 7) 'Запоминаем первые 7 столбцов в массив
                r.Resize(UBound(brr, 1), UBound(brr, 2)) = brr  'В ячейку на листе новая вносим массив.
                r.Cells(1, UBound(brr, 2) + 1).Value = "Удалена"    'Справа дописываем новая.
 
                Set r = r.Cells(2, 1)   'Сдвигаем ячейку, в которую будем вставлять данные.
            End If
        Next
    End With
End Sub

Sub OnlyVal()
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(ActiveSheet.UsedRange, Columns("A:F"))
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim arr As Variant
        arr = r
        r = arr
    End If
End Sub

Sub SozdatFajl3()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    
    Const sFull = "C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость\Деффектная ведомость.xlsx"
    On Error Resume Next
    Workbooks("Деффектная ведомость.xlsx").Close False
    On Error GoTo 0
    If Dir(sFull) <> "" Then Kill sFull
    ActiveWorkbook.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Sub ПеренестиРазное()
    Dim y As Long
    Dim u As Long
    Dim v As Variant
    With Sheets("Разное")
        Dim arR As Variant
        Dim brr As Variant
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arR = .Range(.Cells(1, 1), .Cells(y, 1 - (y = 1)))
        For y = 2 To UBound(arR, 1)
            If arR(y, 1) <> "" Then
                For Each v In Array("/", "(", Chr(160))
                    arR(y, 1) = Replace(arR(y, 1), v, " ")
                Next
                arR(y, 1) = Trim(arR(y, 1))
                brr = Split(arR(y, 1), " ")
                u = 0
                On Error Resume Next
                u = WorksheetFunction.Match(brr(0), Sheets("Основной прайс").Columns(1), 0)
                On Error GoTo 0
                If u > 0 Then
                    Sheets("Основной прайс").Rows(u + 1).Insert Shift:=xlDown
                    .Rows(y).Copy Sheets("Основной прайс").Cells(u + 1, 1)
                    Sheets("Основной прайс").Cells(u + 1, 1).EntireRow.Interior.Color = RGB(200, 255, 200)
                End If
            End If
        Next
    End With
End Sub

Sub SozdatFajl2()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    ActiveWorkbook.SaveAs Filename:="C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость\Деффектная ведомость.xlsx", FileFormat:= xlOpenXMLWorkbook, CreateBackup:=False
End Sub

=СУММЕСЛИМН($D$2:$D$11;$A$2:$A$11;"яблоко";$B$2:$B$11;"<>122";$B$2:$B$11;"<>128")+СУММЕСЛИМН($D$2:$D$11;$A$2:$A$11;"молоко";$B$2:$B$11;"<>122";$B$2:$B$11;"<>128")+...

Sub SozdatFajl2()
    ActiveSheet.Copy
    Range("S1:XFD1048576").Delete Shift:=xlToLeft
    Range("A1:I1048576").Delete Shift:=xlToLeft
    Rows("46:1048576").Delete Shift:=xlUp
    ActiveWorkbook.SaveAs Filename:="C:\Users\TsarakovRCh\Documents\Тестирование\Деффектная ведомость.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

Sub Спортлото89()
    Dim arr As Variant
    arr = GetArr(Range("A1:G1"))
    Range("B2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr(r As Range) As Variant
    Dim s As Long
    s = r.Cells(1, 1).Value
    Dim arr As Variant
    arr = r.Range("B1:G1")
    Dim x As Long
    Dim y As Long
    y = 1
    For x = UBound(arr, 2) To 1 Step -1
        If arr(1, x) = "" Then
            y = y * 49
        End If
    Next
    Dim brr As Variant
    If y > Rows.Count - 2 Then y = Rows.Count - 2
    ReDim brr(1 To y, 1 To 6)
    If y > 1 Then
        Dim i1 As Byte
        Dim i2 As Byte
        Dim i3 As Byte
        Dim i4 As Byte
        Dim i5 As Byte
        Dim i6 As Byte
        y = 0
        
        For i1 = IIf(arr(1, 1) = "", 1, arr(1, 1)) To IIf(arr(1, 1) = "", 49, arr(1, 1))
        For i2 = IIf(arr(1, 2) = "", i1 + 1, arr(1, 2)) To IIf(arr(1, 2) = "", 49, arr(1, 2))
        For i3 = IIf(arr(1, 3) = "", i2 + 1, arr(1, 3)) To IIf(arr(1, 3) = "", 49, arr(1, 3))
        For i4 = IIf(arr(1, 4) = "", i3 + 1, arr(1, 4)) To IIf(arr(1, 4) = "", 49, arr(1, 4))
        For i5 = IIf(arr(1, 5) = "", i4 + 1, arr(1, 5)) To IIf(arr(1, 5) = "", 49, arr(1, 5))
        For i6 = IIf(arr(1, 6) = "", i5 + 1, arr(1, 6)) To IIf(arr(1, 6) = "", 49, arr(1, 6))
            If s = i1 + i2 + i3 + i4 + i5 + i6 Then
                y = y + 1
                brr(y, 1) = i1
                brr(y, 2) = i2
                brr(y, 3) = i3
                brr(y, 4) = i4
                brr(y, 5) = i5
                brr(y, 6) = i6
            End If
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
    End If
    GetArr = brr
End Function

='Нормы СИЗ'!H2            =ЕСЛИ(A2="";H1;A2)

A24       =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!$C:$C;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")
AD24      =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!D:D;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")
AQ24      =ЕСЛИ(СТРОКА(A1)-1<СЧЁТЕСЛИ('Нормы СИЗ'!$G:$G;$M$13);ИНДЕКС('Нормы СИЗ'!E:E;МАКС(($O$12='Нормы СИЗ'!$H$2:$H$18)*($M$13='Нормы СИЗ'!$G$2:$G$18)*СТРОКА('Нормы СИЗ'!$G$2:$G$18))+СТРОКА(A1)-1);"")

=ВПР(F:F;C:D;2;0)