Sub macroc2()
Application.ScreenUpdating = False
Dim i As Long
i = Sheets("лист1").Cells(Rows.Count, 4).End(xlUp).Row
Sheets("лист1").Range("D16:L" & i).Copy
i = Sheets("лист3").Cells(Rows.Count, 2).End(xlUp).Row + 1 'Îïðåäåëÿåì íèæ.Ñòðîêó
Sheets("лист3").Range("A" & i).Paste
Application.ScreenUpdating = True
End Sub

Sub Macro1()
    Range("A1:P1").Copy
    Cells(Application.Max(25, Cells(Rows.Count, 1).End(xlUp)(2).Row), 1).PasteSpecial xlPasteValues
End Sub

=ЕСЛИ(СУММ(G108:G113)>=1;"+";"")

Sub DeleteSheets()
Dim i As Integer
Application.DisplayAlerts = False
   For i = Sheets.Count To 2 Step -1
       If IsEmpty(Sheets(i).Cells(139, 24)) Then Sheets(i).Delete
   Next
Application.DisplayAlerts = True
End Sub

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Sub перенос()
Dim i As Long, j As Integer, ws As Worksheet, aws As Worksheet, x As Range
    Set x = Rows(1).Find("исследование", , , xlWhole)
    If x Is Nothing Then Exit Sub Else j = x.Column
    Application.ScreenUpdating = False: Set aws = Sheets("реестр")
    For i = aws.Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1
        If aws.Cells(i, j) <> "" Then
            On Error Resume Next: Set ws = ThisWorkbook.Sheets(CStr(aws.Cells(i, j)))
            If Err <> 0 Then
                Set ws = Sheets.Add: ActiveSheet.Name = aws.Cells(i, j): On Error GoTo 0
                aws.Cells.Copy
                ws.Cells.PasteSpecial Paste:=xlPasteColumnWidths
                ws.Cells.PasteSpecial Paste:=xlPasteFormats
            End If
            W = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 'номер строки куда вставлять
            aws.Range("A" & i & ":V" & i).Copy ws.Cells(W, 1)
            aws.Range("Y" & i & ":W" & i).Copy ws.Cells(W, "Y")
    End If: Next
End Sub

Sub t()
    For Each s In ThisWorkbook.Sheets
        s.Rows("25:25").Hidden = True
    Next s
End Sub
Sub hhh()
    For Each s In ThisWorkbook.Sheets
        s.Rows("25:25").Hidden = False
    Next s
End Sub

Sub Hide()
    Dim cell As Range
    Application.ScreenUpdating = False                              'отключаем обновление экрана для ускорения
    For Each cell In ActiveSheet.UsedRange.Rows(1).Cells            'проходим по всем ячейкам первой строки
        If cell.Value = "x" Then cell.EntireColumn.Hidden = True    'если в ячейке x - скрываем столбец
    Next
    For Each cell In ActiveSheet.UsedRange.Columns(1).Cells         'проходим по всем ячейкам первого столбца
        If cell.Value = "x" Then cell.EntireRow.Hidden = True       'если в ячейке x - скрываем строку
    Next
    Application.ScreenUpdating = True
End Sub
 
Sub Show()
    Columns.Hidden = False   'отменяем все скрытия строк и столбцов
    Rows.Hidden = False
End Sub

Sub printtt()
    Dim sh As Worksheet
    For Each sh In Worksheets
       If Not IsError(sh.Cells(55, 16).Value) Then
         If sh.Cells(55, 16) <> "" Then
             sh.PrintOut Copies:=1
         End If
       End If
    Next sh
End Sub

Sub HideByConditionalFormattingColor()
    Dim cell As Range
    Application.ScreenUpdating = False
    For Each cell In ActiveSheet.UsedRange.Columns(1).Cells
        If cell.DisplayFormat.Interior.Color = Range("G2").DisplayFormat.Interior.Color Then cell.EntireRow.Hidden = True
    Next
    Application.ScreenUpdating = True
End Sub

Sub Hide()
    Dim cell As Range
    Application.ScreenUpdating = False                              'отключаем обновление экрана для ускорения
    For Each cell In ActiveSheet.UsedRange.Rows(1).Cells            'проходим по всем ячейкам первой строки
        If cell.Value = "#Н/Д" Then cell.EntireColumn.Hidden = True    'если в ячейке x - скрываем столбец
    Next
    For Each cell In ActiveSheet.UsedRange.Columns(2).Cells         'проходим по всем ячейкам первого столбца
        If cell.Value = "#Н/Д" Then cell.EntireRow.Hidden = True       'если в ячейке x - скрываем строку
    Next
    Application.ScreenUpdating = True
End Sub
  
Sub Show()
    Columns.Hidden = False   'отменяем все скрытия строк и столбцов
    Rows.Hidden = False
End Sub