Sub Удалить_Строки()
Dim iSh As Worksheet
Application.ScreenUpdating = False
For Each iSh In ThisWorkbook.Worksheets
  With iSh
  If .Name = "Яблоко" Or .Name = "Груша" Then
    .Rows(ActiveCell.Row).Rows("1:4").Delete Shift:=xlUp
  End If
  End With
Next
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    
    Workbook_BeforeClose False
    
    ' Проверяем какой OptionButton выбран
    If OptionButton1.Value Then
        Set ws = ThisWorkbook.Sheets("Лист2") ' Замените "Лист2" на имя вашего листа
    ElseIf OptionButton2.Value Then
        Set ws = ThisWorkbook.Sheets("Лист3") ' Замените "Лист3" на имя вашего листа
    ElseIf OptionButton3.Value Then
        Set ws = ThisWorkbook.Sheets("Лист4") ' Замените "Лист4" на имя вашего листа
    ElseIf OptionButton4.Value Then
        Set ws = ThisWorkbook.Sheets("Лист4") ' Замените "Лист4" на имя вашего листа
    End If

    ' Показываем выбранный лист
    If Not ws Is Nothing Then
        ws.Visible = xlSheetVisible
        ThisWorkbook.Sheets("Лист1").Select 'Важно: выберите любой видимый лист, чтобы избежать ошибки
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next ' Игнорировать ошибки, если листы не найдены
    ThisWorkbook.Sheets("Лист2").Visible = xlSheetHidden ' Замените "Лист2" на имя вашего листа
    ThisWorkbook.Sheets("Лист3").Visible = xlSheetHidden ' Замените "Лист3" на имя вашего листа
    ThisWorkbook.Sheets("Лист4").Visible = xlSheetHidden ' Замените "Лист4" на имя вашего листа
    ThisWorkbook.Sheets("Лист5").Visible = xlSheetHidden ' Замените "Лист4" на имя вашего листа
    On Error GoTo 0 ' Включить обработку ошибок снова
End Sub

=ЕСЛИОШИБКА(НАЙТИ(",";C3);ДЛСТР(C3)+1)<ДЛСТР(C3)-2

=ЕСЛИОШИБКА(ЗНАЧЕН(ТЕКСТ(C3;"0,"&ПОВТОР("0";МИН(2;ДЛСТР(C3)-НАЙТИ(",";C3)))));C3)

Option Explicit

Sub Сдвинуть()
    CloseEmptyWb
    ActiveSheet.Copy
    Dim sh As Worksheet, arr As Variant
    Set sh = ActiveSheet
    arr = sh.Cells(1, 1).Resize(sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1, sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1).Value
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim xa As Long, ya As Long, xb As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If arr(ya, xa) <> "" Then
                If xa > dic(arr(ya, xa)) Then dic(arr(ya, xa)) = xa
            End If
        Next
    Next
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim dicY As Object: Set dicY = CreateObject("Scripting.Dictionary")
    Dim xMust As Long, rFind As Range, rAfter As Range, rMove As Range, startAddress As Long
    
    For xa = 1 To UBound(arr, 2)
        If arr(1, xa) <> "" Then
            If dic.Exists(arr(1, xa)) Then
                For xb = 1 To UBound(arr, 2)
                For ya = 1 To UBound(arr, 1)
                    If arr(1, xa) = arr(ya, xb) Then
                        If dicY.Count = 0 Then
                            dicY(ya) = Empty
                        Else
                            If ya > dicY.keys()(dicY.Count - 1) Then
                                dicY(ya) = Empty
                            End If
                        End If
                    End If
                Next
                Next
            End If
        End If
    Next
    ya = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
    dicY(ya) = Empty
    
    For ya = 1 To dicY.Count - 1
        dicY(dicY.keys()(ya - 1)) = dicY.keys()(ya)
    Next
    
    Dim ys As Byte
    For ys = 1 To 2
        For xa = 1 To UBound(arr, 2)
            If arr(1, xa) <> "" Then
                If dic.Exists(arr(1, xa)) Then
                    xMust = dic(arr(1, xa))
                    Set rAfter = sh.Cells(1, 1)
                    startAddress = 0
                    Do
                        Set rFind = Nothing
                        On Error Resume Next
                        Set rFind = sh.UsedRange.Find(what:=arr(1, xa), After:=rAfter, LookAt:=xlWhole)
                        On Error GoTo 0
                        If rFind Is Nothing Then Exit Do
                        If startAddress = rFind.Row Then Exit Do
                        If startAddress = 0 Then startAddress = rFind.Row
                            
                        Application.StatusBar = arr(1, xa) & " " & xa & " " & rFind.Row
                            
                        If dicY.Exists(rFind.Row) Then
                            If xMust > rFind.Column Then
                                Set rMove = rFind.Resize(dicY(rFind.Row) - rFind.Row, xMust - rFind.Column)
                                rMove.Select
                                On Error Resume Next
                                rMove.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                                If Err <> 0 Then sh.UsedRange.AutoFilter
                                On Error GoTo 0
                            ElseIf xMust < rFind.Column Then
                                Set rMove = rFind.Resize(dicY(rFind.Row) - rFind.Row, sh.UsedRange.Column + sh.UsedRange.Columns.Count - rFind.Column)
                                rMove.Select
                                
                                sh.Cells(rMove.Row, xMust).Resize(rMove.Rows.Count, rMove.Columns.Count).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                                rMove.Cut
                                sh.Cells(rMove.Row, xMust).Select
                                ActiveSheet.Paste
                                Application.CutCopyMode = False
                            End If
                        End If
                        Set rAfter = rFind
                        
                        DoEvents
                    Loop
                End If
            End If
        Next
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Sub CreateAndSaveCharts()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    Dim dic As Object
    Set dic = GetDic(ws)
    
    Dim vv As Variant
    For Each vv In dic
        PrefixJob ws, vv
    Next
End Sub
    
Private Sub PrefixJob(sourceSheet As Worksheet, ByVal prefix As String)
    sourceSheet.Copy
    Dim xx As Long
    For xx = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1 To 2 Step -1
        If Left(Cells(1, xx).Value, Len(prefix)) <> prefix Then
            Columns(xx).EntireColumn.Delete
        End If
    Next
    CreateAndSaveChartsOneSheet ActiveSheet, prefix
    ActiveWorkbook.Close False
End Sub
    
Private Function GetDic(ws As Worksheet) As Object
    Dim lastCol As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim xx As Long, ss As String, arr As Variant
    For xx = 2 To lastCol
        ss = ws.Cells(1, xx).Value
        If ss <> "" Then
            arr = Split(ss, " ")
            dic(arr(LBound(arr))) = Empty
        End If
    Next
    Set GetDic = dic
End Function

Sub CreateAndSaveChartsOneSheet(ws As Worksheet, extprefix As String)
    Dim chartObj As ChartObject
    Dim chartName As String
    Dim prefix As String
    Dim lastRow As Long
    Dim lastCol As Long
    Dim j As Long
    Dim savePath As String
      
    ' Определите диапазон данных
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
      
    ' Установите путь для сохранения изображений
    savePath = ThisWorkbook.Path & "\"
      
    ' Проверка пути сохранения (выводим в сообщение)
    'MsgBox "Сохранение графиков в: " & savePath
      
    ' Цикл по всем столбцам, начиная со второго (первый - ось X)
    'For j = 2 To lastCol
        ' Проверка наличия данных в текущем столбце
        If Application.WorksheetFunction.CountA(ws.Range(ws.Cells(2, 2), ws.Cells(lastRow, 2))) > 0 Then
              
            ' Получаем префикс из заголовка столбца и очищаем его от недопустимых символов
            prefix = CleanFileName(ws.Cells(1, 2).Value)
              
            ' Создаем новый график
            'Set chartObj = ws.ChartObjects.Add(Left:=100, Top:=100 + (j - 2) * 200, Width:=375, Height:=225)
            Set chartObj = ws.ChartObjects.Add(Left:=100, Top:=100 + (1 - 2) * 200, Width:=375, Height:=225)
            With chartObj.Chart
                  
                Debug.Print "Создание графика для: " & prefix
                  
                ' Убедитесь, что данные корректно передаются в график
                .SetSourceData Source:=ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
                '.FullSeriesCollection(1).Values = "='" & ws.Name & "'!" & Range(Cells(2, j), Cells(lastRow, j)).Address(1, 1, xlA1)
                  
                Debug.Print "Диапазон данных: " & ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1)).Address
                  
                ' Установка типа графика и заголовков
                .ChartType = xlLine
                  
                .HasTitle = True
                .ChartTitle.Text = extprefix & " График"
                .Axes(xlCategory).HasTitle = True
                .Axes(xlCategory).AxisTitle.Text = ws.Cells(1, 1).Value ' Заголовок оси X
                  
'                .Axes(xlValue).HasTitle = True
'                .Axes(xlValue).AxisTitle.Text = ws.Cells(1, 2).Value ' Заголовок оси Y
                  
                ' Сохранение графика как изображения с обработкой ошибок
                On Error Resume Next
                  
                chartName = savePath & prefix & "_График_" & Format(Now(), "yyyymmdd_hhnnss") & ".png"
                  
                .Export fileName:=chartName, FilterName:="PNG"
                  
                If Err.Number <> 0 Then
'                    MsgBox "Ошибка при сохранении графика: " & Err.Description, vbExclamation
                    Err.Clear ' Сбрасываем ошибку для следующей итерации
                End If
                  
                On Error GoTo 0
                  
            End With
              
            ' Удаляем график после сохранения (если не нужно оставлять на листе)
'            chartObj.Delete
              
        Else
            Debug.Print "Нет данных для столбца: " & ws.Cells(1, 2).Value
        End If
          
'    Next j
      
'    MsgBox "Графики успешно созданы и сохранены!"
End Sub
  
Function CleanFileName(fileName As String) As String
    Dim invalidChars As Variant
    Dim ii As Long
      
    invalidChars = Array("\", "/", ":", "*", """", "<", ">", "|")
      
    For ii = LBound(invalidChars) To UBound(invalidChars)
        fileName = Replace(fileName, invalidChars(ii), "_")
    Next ii
      
    CleanFileName = fileName
End Function

Sub CreateAndSaveCharts()
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim chartName As String
    Dim prefix As String
    Dim lastRow As Long
    Dim lastCol As Long
    Dim j As Long
    Dim savePath As String
     
    ' Установите рабочий лист (например, первый лист)
    Set ws = ThisWorkbook.Sheets(1)
     
    ' Определите диапазон данных
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
     
    ' Установите путь для сохранения изображений
    savePath = ThisWorkbook.Path & "\"
     
    ' Проверка пути сохранения (выводим в сообщение)
    MsgBox "Сохранение графиков в: " & savePath
     
    ' Цикл по всем столбцам, начиная со второго (первый - ось X)
    For j = 2 To lastCol
        ' Проверка наличия данных в текущем столбце
        If Application.WorksheetFunction.CountA(ws.Range(ws.Cells(2, j), ws.Cells(lastRow, j))) > 0 Then
             
            ' Получаем префикс из заголовка столбца и очищаем его от недопустимых символов
            prefix = CleanFileName(ws.Cells(1, j).Value)
             
            ' Создаем новый график
            'Set chartObj = ws.ChartObjects.Add(Left:=100, Top:=100 + (j - 2) * 200, Width:=375, Height:=225)
            Set chartObj = ws.ChartObjects.Add(Left:=100, Top:=100 + (1 - 2) * 200, Width:=375, Height:=225)
            With chartObj.Chart
                 
                Debug.Print "Создание графика для: " & prefix
                 
                ' Убедитесь, что данные корректно передаются в график
                .SetSourceData Source:=ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 2))
                .FullSeriesCollection(1).Values = "='" & ws.Name & "'!" & Range(Cells(2, j), Cells(lastRow, j)).Address(1, 1, xlA1)
                 
                Debug.Print "Диапазон данных: " & ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, j)).Address
                 
                ' Установка типа графика и заголовков
                .ChartType = xlLine
                 
                .HasTitle = True
                .ChartTitle.Text = prefix & " График"
                .Axes(xlCategory).HasTitle = True
                .Axes(xlCategory).AxisTitle.Text = ws.Cells(1, 1).Value ' Заголовок оси X
                 
                .Axes(xlValue).HasTitle = True
                .Axes(xlValue).AxisTitle.Text = ws.Cells(1, j).Value ' Заголовок оси Y
                 
                ' Сохранение графика как изображения с обработкой ошибок
                On Error Resume Next
                 
                chartName = savePath & prefix & "_График_" & Format(Now(), "yyyymmdd_hhnnss") & ".png"
                 
                .Export fileName:=chartName, FilterName:="PNG"
                 
                If Err.Number <> 0 Then
                    MsgBox "Ошибка при сохранении графика: " & Err.Description, vbExclamation
                    Err.Clear ' Сбрасываем ошибку для следующей итерации
                End If
                 
                On Error GoTo 0
                 
            End With
             
            ' Удаляем график после сохранения (если не нужно оставлять на листе)
            chartObj.Delete
             
        Else
            Debug.Print "Нет данных для столбца: " & ws.Cells(1, j).Value
        End If
         
    Next j
     
    MsgBox "Графики успешно созданы и сохранены!"
End Sub
 
Function CleanFileName(fileName As String) As String
    Dim invalidChars As Variant
    Dim ii As Long
     
    invalidChars = Array("\", "/", ":", "*", """", "<", ">", "|")
     
    For ii = LBound(invalidChars) To UBound(invalidChars)
        fileName = Replace(fileName, invalidChars(ii), "_")
    Next ii
     
    CleanFileName = fileName
End Function

=ЕСЛИОШИБКА(ИНДЕКС($C$3:$I$44;СТРОКА($B$45)-СТРОКА($B$2)-НАИБОЛЬШИЙ((($B$3:$B$44=$K$1)+($K$1=0))*(($C$3:$C$44=$L$1)+($L$1=0))*(СТРОКА($B$45)-СТРОКА($B$3:$B$44));СТОЛБЕЦ(A1));СТРОКА(A1));"")

Sub NewFile()
    Dim CellValue As String
    CellValue = Range("N8")
   
    Dim Path As String
    Path = ThisWorkbook.Path & "\"
   
   Dim FinalFileName As String
   FinalFileName = Path & CellValue
   
    Dim wbSource As Workbook, wbTarget As Workbook
    Set wbSource = ActiveWorkbook
    
    Dim vName As Variant
    For Each vName In Array("Лист1", "Лист2")
        If wbTarget Is Nothing Then
            wbSource.Sheets(vName).Copy
            Set wbTarget = ActiveWorkbook
        Else
            wbSource.Sheets(vName).Copy After:=wbTarget.Sheets(wbTarget.Sheets.Count)
        End If
    Next
    Sheets(1).Activate
    Dim ws As Worksheet
    For Each ws In wbTarget.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next ws
    
   On Error Resume Next
   Workbooks(CreateObject("Scripting.FileSystemObject").GetFileName(FinalFileName)).Close False
   Kill FinalFileName
   Err.Clear
   wbTarget.SaveAs Filename:=FinalFileName, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    
    
End Sub

Option Explicit
Sub SaveTimesheet()
    Dim shSource As Worksheet
    Set shSource = Sheets("V-06 RuR")
    
    Dim sName As String, sFull As String
    sName = Sheets("НЕ ЛЕЗЬ").Range("C39").Value
    ReplaceSymbols sName
    sName = sName & ".xlsx"
    
    sFull = ActiveWorkbook.Path & "\" & sName
    
    shSource.Copy
    Dim wbTarget As Workbook
    Set wbTarget = ActiveWorkbook
    
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    Err.Clear
    wbTarget.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err <> 0 Then
        MsgBox Err.Description, vbCritical, "SaveTimesheet"
        Exit Sub
    End If
    On Error GoTo 0
    
    shSource.Parent.Close False
End Sub

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
    ss = Trim(ss) 'Пробел в конце строки не распознаётся файловой системой.
End Sub

=СУММПРОИЗВ((Данные!$F$5:$J$5&Данные!$F$6:$J$6=D$3&D$4)*(Данные!$E$7:$E$41=$C7)*Данные!$F$7:$J$41)

=ЕСЛИ(C6="Прямые расходы";"прямые";ЕСЛИ(C6="Общепроизводственные расходы";"общепр";ЕСЛИ(C6="Общехозяйственные расходы";"общехоз";ЕСЛИ(C6="Прочее";"Прочее";B5))))

=ЕСЛИ($B6="прямые";СУММЕСЛИМН(Данные!F:F;Данные!$E:$E;$C:$C;Данные!$C:$C;"Прямые");
ЕСЛИ($B6="Прочее";СУММЕСЛИМН(Данные!F:F;Данные!$C:$C;$C:$C;Данные!$C:$C;"Прочие*");
СУММЕСЛИМН(Данные!F:F;Данные!$E:$E;$C:$C;Данные!$D:$D;$B:$B)))

Option Explicit

Sub Кнопка1_Щелчок()
    Dim vFile As Variant, wbSource As Workbook, wbTarget As Workbook, needClose As Boolean
    Set wbTarget = ActiveWorkbook
    
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    For Each vFile In aFiles
        Set wbSource = GetWb(vFile, needClose)
        If Not wbSource Is Nothing Then
            CopyFromWb wbSource, wbTarget
            If needClose Then wbSource.Close False
            Set wbSource = Nothing
        End If
    Next
End Sub

Private Sub CopyFromWb(wbSource As Workbook, wbTarget As Workbook)
    Dim arr As Variant
    arr = wbSource.Sheets(1).ListObjects(1).DataBodyRange
    
    Dim tbTarget As ListObject
    Set tbTarget = wbTarget.Sheets("Товарный чек").ListObjects(1)
    
    Dim ii As Long
    For ii = 1 To UBound(arr, 1)
        tbTarget.ListRows.Add AlwaysInsert:=True
    Next
    
    With tbTarget.DataBodyRange
        .Cells(.Rows.Count + 1 - UBound(arr, 1), 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
End Sub

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim rInitialFileName As Range, sInitialFileName As String
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("SourceFile").RefersToRange
    sInitialFileName = rInitialFileName.Value
    On Error GoTo 0
    If sInitialFileName = "" Then sInitialFileName = ThisWorkbook.Path & "\"
    If Left(sInitialFileName, 2) = ".\" Then
        sInitialFileName = Mid(sInitialFileName, 2)
        sInitialFileName = ThisWorkbook.Path & sInitialFileName
    End If
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                        If Not rInitialFileName Is Nothing Then
                            sInitialFileName = .SelectedItems(lf)
                            sInitialFileName = Replace(sInitialFileName, ThisWorkbook.Path, ".")
                            rInitialFileName.Value = sInitialFileName
                        End If
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String, needClose As Boolean) As Workbook
    needClose = False
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, True)
        needClose = True
    End If
    
    Set GetWb = wb
End Function

=(СУММЕСЛИМН(A1:A3;A1:A3;">0")+СУММЕСЛИМН(A1:A3;A1:A3;"<0"))/(СЧЁТЕСЛИМН(A1:A3;">=0")+СЧЁТЕСЛИМН(A1:A3;"<0"))

=ЕСЛИОШИБКА(ВПР(что_ищем;таблица_1;2;0);ЕСЛИОШИБКА(ВПР(что_ищем;таблица_2;2;0);ЕСЛИОШИБКА(ВПР(что_ищем;таблица_3;2;0);ЕСЛИОШИБКА(ВПР(что_ищем;таблица_4;2;0);""))))

Sub сохранить()
Dim wb As Workbook
Dim s As Worksheet
Set wb = ActiveWorkbook
For Each s In wb.Worksheets(Array("Лист1"))
  s.Copy
  With ActiveWorkbook
    .Worksheets(1).UsedRange.Value = s.UsedRange.Value
    .SaveAs wb.Path & "\" & s.Name & s.Range("K5") & ".xlsx"
  End With
Next
End Sub

Option Explicit

Sub CopyDataBasedOnValue()
    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim searchValue As String
    Dim foundCell As Range
    Dim afterCell As Range
    Dim firstFoundCellRow As Long
    Dim firstFoundCellColumn As Long
    Dim lastRow As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim newRow As Range
 
    ' Установите рабочий лист
    Set ws = ThisWorkbook.Sheets(1)
    searchValue = InputBox("Введите значение для поиска:")
    
    Set afterCell = ws.Cells(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count)
    
    ' Создайте новый лист для копирования данных
    Set wsNew = ThisWorkbook.Sheets.Add
    Set newRow = wsNew.Rows(1)
    
    Do
       ' Найдите строку с искомым значением
       Set foundCell = ws.Cells.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole, After:=afterCell)
    
       If foundCell Is Nothing Then Exit Do
       If firstFoundCellRow = 0 Then
            firstFoundCellRow = foundCell.Row
            firstFoundCellColumn = foundCell.Column
        ElseIf firstFoundCellRow = foundCell.Row Then
            If firstFoundCellColumn = foundCell.Column Then Exit Do
       End If
       Set afterCell = foundCell
       Application.Goto afterCell
       
        startRow = foundCell.Row
 
        ' Найдите строку с "Ответственный исполнитель"
        Set foundCell = ws.Cells.Find(What:="Ответственный исполнитель", LookIn:=xlValues, LookAt:=xlWhole, After:=foundCell)
         
        If Not foundCell Is Nothing Then
            endRow = foundCell.Row
             
 
            ' Скопируйте диапазон с сохранением формата
            ws.Rows(startRow & ":" & endRow).Copy Destination:=newRow
            
            Set newRow = newRow.Rows(Rows(startRow & ":" & endRow).Rows.Count + 1)
            
            'MsgBox "Данные успешно скопированы на новый лист."
        Else
            MsgBox "'Ответственный исполнитель' не найден."
        End If
'    Else
'        MsgBox "Значение не найдено."
'    End If
        
        DoEvents
    Loop
End Sub

If flag Then CopyRange "ВСЕ БЛАНКИ", "A1:M30"

Option Explicit

Private rPrint As Range
Private wbSource As Workbook
Private pagesCount As Long
Private Const pagesPerSheet = 2
 
Sub test()
    CloseEmptyWb
    Set rPrint = Nothing
    Set wbSource = ActiveWorkbook
    
    Dim flag As Boolean
    flag = True
     
    If flag Then CopyRange "ВСЕ БЛАНКИ", "A1:M30"    'НАПРАВЛЕНИЕ В ИММУНОЛОГИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ОПРЕДЕЛЕНИЕ Hbs Ag, АНТИ ВГС, ДРУГИЕ МАРКЕРЫ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "A33:M62"   'НАПРАВЛЕНИЕ В ИММУНОЛОГИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  АНАЛИЗ КРОВИ НА ВИЧ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "N1:Z30"    'НАПРАВЛЕНИЕ В ИММУНОЛОГИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ОПРЕДЕЛЕНИЕ АНТИТЕЛ К TREPONEMA PALLIDUM
    If flag Then CopyRange "ВСЕ БЛАНКИ", "N33:Y62"   'НАПРАВЛЕНИЕ В КОЖНО-ВЕНЕРОЛОГИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ОПРЕДЕЛЕНИЕ РЕАКЦИИ МИКРОПРЕЦИПИТАЦИИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "AA1:AM30"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ДЛЯ ОПРЕДЕЛЕНИЯ КОНЦЕНТРАЦИИ ПРОКАЛЬЦИТОНИНА В КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "AA33:AM62" 'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ДЛЯ КАЧЕСТВЕННОГО ОПРЕДЕЛЕНИЯ ТРОПОНИНА В КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "AN1:AZ32"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА КОАГУЛОГРАММУ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "AN33:AZ63" 'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ДЛЯ ОПРЕДЕЛЕНИЯ ЭЛЕКТРОЛИТОВ КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "BA1:BM32"  'НАПРАВЛЕНИЕ В ДЕЖУРНУЮ  КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА БИОХИМИЧЕСКИЙ АНАЛИЗ КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "BA47:BM82" 'НАПРАВЛЕНИЕ В ДЕЖУРНУЮ  КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА БИОХИМИЧЕСКИЙ АНАЛИЗ КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "BN1:BZ38"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ОБЩЕКЛИНИЧЕСКИЙ АНАЛИЗ МОЧИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "BN41:BZ66" 'НАПРАВЛЕНИЕ В ДЕЖУРНУЮ  КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ОБЩЕКЛИНИЧЕСКИЙ АНАЛИЗ КРОВИ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "CA1:CM37"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НАПРАВЛЕНИЕ НА ЦИТОЛОГИЧЕСКОЕ ИССЛЕДОВАНИЕ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "CN1:CZ31"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ДЛЯ ОПРЕДЕЛЕНИЯ ГРУППОВОЙ ПРИНАДЛЕЖНОСТИ И РЕЗУС ФАКТОРА
    If flag Then CopyRange "ВСЕ БЛАНКИ", "CN34:CZ63" 'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ИССЛЕДОВАНИЕ КАЛА НА СКРЫТУЮ КРОВЬ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "DA1:DM40"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НА ПРОВЕДЕНИЕ АНАЛИЗА МОКРОТЫ ДЛЯ ДИАГНОСТИКИ КУМ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "DN1:DZ37"  'НАПРАВЛЕНИЕ В КОЖНО-ВЕНЕРОЛОГИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ИССЛЕДОВАНИЕ ГИНЕКОЛОГИЧЕСКОГО МАЗКА НА ФЛОРУ
    If flag Then CopyRange "ВСЕ БЛАНКИ", "EA1:EM31"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  НАПРАВЛЕНИЕ НА АНАЛИЗ МОЧИ ПО НЕЧИПОРЕНКО
    If flag Then CopyRange "ВСЕ БЛАНКИ", "EN1:EZ32"  'НАПРАВЛЕНИЕ В КЛИНИКО-ДИАГНОСТИЧЕСКУЮ ЛАБОРАТОРИЮ ГБУЗ ВО «АРБ»  ПРОБА РЕБЕРГА
     
    Set rPrint = Nothing
End Sub
 
Private Sub CopyRange(sheetName As String, rangeAddress As String)
    If rPrint Is Nothing Then
        wbSource.Sheets(sheetName).Copy
        Set rPrint = ActiveSheet.Cells(1)
        rPrint.Parent.Cells.Clear
        rPrint.Parent.Name = "print sheet"
        rPrint.Parent.PageSetup.Zoom = 73
    End If
     
    Dim rSource As Range
    Set rSource = wbSource.Sheets(sheetName).Range(rangeAddress)
    Set rPrint = rPrint.Cells(1).Resize(rSource.Rows.Count, rSource.Columns.Count)
    rSource.Copy rPrint
    rPrint.Value = rSource.Value
    
    rPrint.Parent.PageSetup.PrintArea = "$A$1:" & rPrint.Cells(rPrint.Rows.Count, rPrint.Columns.Count).Address(1, 1, xlA1)
    Set rPrint = rPrint.Cells(rPrint.Rows.Count + 1, 1)
     
    pagesCount = pagesCount + 1
    If pagesCount >= pagesPerSheet Then
        pagesCount = 0
        rPrint.Parent.HPageBreaks.Add Before:=rPrint
    End If
    
    rPrint.Parent.Parent.Saved = True
End Sub
 
Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Private rPrint As Range
Private wbSource As Workbook
Private pageCount As Long
Private Const pagePerSheet = 2
 
Sub test()
    CloseEmptyWb
    Set rPrint = Nothing
    Set wbSource = ActiveWorkbook
     
    CopyRange "ВСЕ БЛАНКИ", "A1:M30"
    CopyRange "ВСЕ БЛАНКИ", "N33:Z62"
    CopyRange "ВСЕ БЛАНКИ", "AA1:AM30"
     
    Set rPrint = Nothing
End Sub
 
Private Sub CopyRange(sheetName As String, rangeAddress As String)
    If rPrint Is Nothing Then
        wbSource.Sheets(sheetName).Copy
        Set rPrint = ActiveSheet.Cells(1)
        rPrint.Parent.Cells.Clear
        rPrint.Parent.Name = "print sheet"
        rPrint.Parent.PageSetup.Zoom = 73
    End If
     
    Dim rSource As Range
    Set rSource = wbSource.Sheets(sheetName).Range(rangeAddress)
    Set rPrint = rPrint.Cells(1).Resize(rSource.Rows.Count, rSource.Columns.Count)
    rSource.Copy rPrint
    rPrint.Value = rSource.Value
    
    rPrint.Parent.PageSetup.PrintArea = "$A$1:" & rPrint.Cells(rPrint.Rows.Count, rPrint.Columns.Count).Address(1, 1, xlA1)
    Set rPrint = rPrint.Cells(rPrint.Rows.Count + 1, 1)
     
    pageCount = pageCount + 1
    If pageCount >= pagePerSheet Then
        pageCount = 0
        rPrint.Parent.HPageBreaks.Add Before:=rPrint
    End If
    
    rPrint.Parent.Parent.Saved = True
End Sub
 
Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit
Private rPrint As Range
Private wbSource As Workbook

Sub test()
    CloseEmptyWb
    Set rPrint = Nothing
    Set wbSource = ActiveWorkbook
    
    CopyRange "RW 2бланка", "A1:E33"
    CopyRange "ОАК+ОАМ", "F1:J32"
    
    Set rPrint = Nothing
End Sub

Private Sub CopyRange(sheetName As String, rangeAddress As String)
    If rPrint Is Nothing Then
        wbSource.Sheets(sheetName).Copy
        Set rPrint = ActiveSheet.Cells(1)
        rPrint.Parent.Cells.Clear
        rPrint.Parent.Name = "print sheet"
    End If
    
    Dim rSource As Range
    Set rSource = wbSource.Sheets(sheetName).Range(rangeAddress)
    Set rPrint = rPrint.Cells(1).Resize(rSource.Rows.Count, rSource.Columns.Count)
    rSource.EntireColumn.Copy rPrint
    rPrint.Value = rSource.Value
    
    Set rPrint = rPrint.Cells(1, rPrint.Columns.Count + 1)
    rPrint.Parent.Parent.Saved = True
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=ЕСЛИ(C3=0;F2;МЕСЯЦ(ДАТАЗНАЧ(C3)))

=B5+C5+СМЕЩ(E2;5-СТРОКА();0)

=ЛЕВСИМВ(D7;25)