Sub mrshkei()
    Range("R:R,P:P,N:N,M:M,I:I").Copy Destination:=Range("B1")
End Sub

Sub mrsheki()
Dim lr As Long, i As Long, n As Long

lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
    If Cells(i, 1).RowHeight = 409.5 Then
        Rows(i + 1).Insert
        For n = 1 To 4
            Range(Cells(i, n), Cells(i + 1, n)).Merge
        Next n
    End If
Next i
End Sub

Sub mrshkei()
Dim lr As Long, i As Long, k As Long
k = 0
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    If Cells(i, 1).Interior.ColorIndex = 6 And Cells(i, 2) = 1 And Cells(i, 3) = "годен" Then k = k + 1
Next i
Debug.Print k
End Sub

Sub meshkei()
Dim arr, i As Long, lr As Long, fr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
If Range("A1") = Empty Then
    fr = Range("A1").End(xlDown).Row
Else
    fr = 1
End If

arr = Range("A" & fr & ":A" & lr)
For i = LBound(arr) To UBound(arr)
    If arr(i, 1) = Empty Then
        arr(i, 1) = arr(i - 1, 1)
    End If
Next i
Range("A" & fr).Resize(UBound(arr), 1) = arr
End Sub

Sub Сохранить_НД_в_лист()
Application.ScreenUpdating = False
Dim path As String, iLinks As Variant, i As Long
  
vopros = MsgBox("Сохранить форму загрузки НД?", vbYesNo, "Сохранение")
If vopros = vbYes Then
  
    path = ThisWorkbook.path
    Range("A:F").Copy
    Workbooks.Add
    ActiveWorkbook.Worksheets(1).Paste
    iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(iLinks) Then
        For i = 1 To UBound(iLinks)
            ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks
        Next i
    End If
    ActiveWorkbook.SaveAs path & Application.PathSeparator & ActiveSheet.Name & " " & Range("B10") & " " & Range("B11") & ".xlsx"
    ActiveWorkbook.Close (False)
    MsgBox "Форма сохранена в папку", vbInformation, "Важное сообщение:"
End If
End Sub

Sub mrshkei()
Dim sh As Worksheet, sh2 As Worksheet, cell As Range
Dim i As Long, n As Long, lr As Long, lr2 As Long
Set sh = Worksheets("ФРАЗЫ"): Set sh2 = Worksheets("2. Тексты")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If sh.Cells(i, 1) <> Empty Then
    For n = 1 To lr2
        If sh2.Cells(n, 1) <> Empty Then
            If InStr(1, sh2.Cells(n, 1), sh.Cells(i, 1), vbTextCompare) > 0 Then
                If cell Is Nothing Then
                    Set cell = sh2.Range(sh2.Cells(n, 1), sh2.Cells(n, 8))
                Else
                    Set cell = Union(cell, sh2.Range(sh2.Cells(n, 1), sh2.Cells(n, 8)))
                End If
            End If
        End If
    Next n
End If
Next i
If Not cell Is Nothing Then cell.Interior.ColorIndex = 3
End Sub

=СУММЕСЛИМН(ИНДЕКС($D$5:$I$9;ПРОСМОТР(2;1/(($B$5:$B$9=$K5)*($C$5:$C$9=$L5));СТРОКА($B$5:$B$9))-4;1):ИНДЕКС($D$5:$I$9;ПРОСМОТР(2;1/(($B$5:$B$9=$K5)*($C$5:$C$9=$L5));СТРОКА($B$5:$B$9))-4;6);$D$4:$I$4;M$4)

=ЕСЛИ(МАКС($C2:C2)=0;СЕГОДНЯ();МАКС($C2:C2))-МАКС($B2:B2)

Sub mrshkei()
Dim sh As Worksheet, sh2 As Worksheet, arr, arr2, arr3
Dim i As Long, n As Long, k As Long, lr As Long, lr2 As Long
Set sh = Worksheets("Новая_партия"): Set sh2 = Worksheets("Старая_партия")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row: lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
arr = sh.Range("A1:J" & lr): arr2 = sh2.Range("A1:I" & lr2): ReDim arr3(1 To UBound(arr), 1 To 2)

For i = LBound(arr) + 1 To UBound(arr)
k = 0
    For n = LBound(arr2) + 1 To UBound(arr2)
        If arr(i, 1) = arr2(n, 1) Then
        k = k + 1
        If arr(i, 7) - arr2(n, 7) <> 0 Then
            arr3(i - 1, 1) = "да"
            arr3(i - 1, 2) = "Изменение объема"
            Exit For
        Else
            arr3(i - 1, 1) = Empty
            arr3(i - 1, 2) = Empty
        End If
        End If
        If k = 0 Then
            arr3(i - 1, 1) = "да"
            arr3(i - 1, 2) = "новая позиция"
        End If
    Next n
Next i

sh.Range("I2").Resize(UBound(arr3), 2) = arr3
End Sub

Sub Update()
Dim OT As Range, cell As Range, sh1 As Worksheet, sh2 As Worksheet, arr, i As Long, k As Long
Set sh1 = Worksheets("Матрица")
Set sh2 = Worksheets("График")
arr = sh1.Range("A2:B6")
k = 2
sh2.Range("A2:A7").ClearContents
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = "да" Then
        sh2.Cells(k, 1) = arr(i, 1)
        k = k + 1
    End If
Next i
End Sub

UserForm1.ListBox1.Font.Size = 777