Sub AutoFitAllRows() ' автоподбор высоты объединенных ячеек
Dim rCell As Range, rMergeArea As Range
Dim rColumn As Range, rRow As Range, rRow1 As Range
Dim maxRowHeight!, newCellWidth!, CellWidth!, RowHeight!, CellHeight!, nOldAlignment!
Dim oSheet As Worksheet, oOldSheet As Worksheet
Dim stRowsWithShapes As String, oShape As Shape
    Set oOldSheet = Application.ActiveWorkbook.ActiveSheet
    Application.ScreenUpdating = False
    On Error Resume Next
    For Each oSheet In Application.ActiveWorkbook.Worksheets
        oSheet.Activate
        stRowsWithShapes = ""
        For Each oShape In oSheet.Shapes
            stRowsWithShapes = stRowsWithShapes & "," & oShape.TopLeftCell.Row
        Next oShape
        stRowsWithShapes = stRowsWithShapes & ","
        For Each rRow In ActiveSheet.UsedRange.Rows ' цикл по всем строкам диапазона
            If rRow.RowHeight > 0 And Not (stRowsWithShapes Like ("*," & rRow.Row & ",*")) Then
                maxRowHeight = 0
                For Each rCell In rRow.Cells ' цикл по всем ячейкам строки
                    If (Not rCell.MergeCells And rCell.MergeArea.Cells(1).Text <> "" And rCell.MergeArea.Cells(1).WrapText) Or (rCell.MergeCells And rCell.Address = rCell.MergeArea.Cells(1).Address) Then ' если это первая ячейкам объединенной области
                        Set rMergeArea = rCell.MergeArea
                        newCellWidth = 0
                        With rMergeArea
                            CellHeight = 0     ' запомним высоту в объединенной области без первой строки (для объединенных по вертикали)
                            CellWidth = .Columns(1).ColumnWidth ' запомним ширину первого столюца в объединенной области
                            If CellWidth > 0 Then  ' метод 1 (через выравнивание по центру выделения)
                                nOldAlignment = .HorizontalAlignment
                                .UnMerge
                                For Each rRow1 In .EntireRow: CellHeight = CellHeight + rRow1.RowHeight: Next
                                CellHeight = CellHeight - .Rows(1).RowHeight
                                .HorizontalAlignment = xlCenterAcrossSelection
                                .EntireRow.AutoFit
                                RowHeight = .EntireRow.Rows(1).RowHeight - CellHeight ' запомнить подобранную высоту для этой объединенной области
                                If RowHeight > maxRowHeight Then maxRowHeight = RowHeight ' если подобранная высота для этой объединенной области максимальна в строке, то запомним её
                                .Merge
                                .HorizontalAlignment = nOldAlignment
                            Else                ' метод 2 (через подгон высоты в одной колонке, равной по ширене объединенной)
                                .UnMerge ' разгруппировываем область
                                For Each rColumn In .EntireColumn: newCellWidth = newCellWidth + rColumn.ColumnWidth: Next
                                For Each rRow1 In .EntireRow: CellHeight = CellHeight + rRow1.RowHeight: Next
                                CellHeight = CellHeight - .Rows(1).RowHeight
                                .Columns(1).ColumnWidth = IIf(newCellWidth > 255, 255, newCellWidth) ' делаем ширину первой ячейки такую же, как была у всей объединенной области
                                .EntireRow.Rows(1).AutoFit ' автоподбор высоты первой ячейки объединенной области
                                RowHeight = .EntireRow.Rows(1).RowHeight - CellHeight ' запомнить подобранную высоту для этой объединенной области
                                If RowHeight > maxRowHeight Then maxRowHeight = RowHeight ' если подобранная высота для этой объединенной области максимальна в строке, то запомним её
                                .Merge ' группируем область обратно
                                .Columns(1).ColumnWidth = CellWidth ' восстановим ширину первого столюца
                            End If
                        End With
                    End If
                Next rCell ' повторяем со следующей ячейкой строки
                If maxRowHeight > 0 Then rRow.EntireRow.RowHeight = maxRowHeight ' устанавливаем подобранную максимальную высоту строки
            End If
        Next rRow ' переходим к следующей строке
    Next oSheet
    oOldSheet.Activate
    On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Sub footersize_OtchetRevizNarush()

 Dim fRange,cell1 As Range
 Dim Xbeg,Ybeg As Integer
dim i,j as integer

	
	
	 Set fRange = ActiveSheet.Cells.Find(What:="end", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
		If Not fRange Is Nothing Then
            'Берём случай, когда это верхняя ячейка от диапозона, который размножается по строкам и столбцам
            'Поэтому прибаляем к ней 1 строку и 1 колонку
           
                Xbeg = fRange.Cells.Column-1
                Ybeg = fRange.Cells.Row
          
                         
            'fRange.Value = ""
            fRange.Replace What:="end", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
		 		if Xbeg<6 then 
	Columns("H:H").ColumnWidth=26
	end if
		Else
			Xbeg=1
			Ybeg=1
        End If	
		Set cell1 = Cells(Xbeg, 1)


		'Rows(Top_Row &":" & End_Row).Select
		'Ybeg=1
		'Columns(Ybeg & ":" & Xbeg).Select
		Cells(1,Xbeg).Select
		'Range("D2:" & Cells(2,Xbeg)).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
	Cells(2,Xbeg).Select
		'Range("D2:" & Cells(2,Xbeg)).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
	Cells(3,Xbeg).Select
		'Range("D2:" & Cells(2,Xbeg)).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
	    ActiveWindow.View = xlNormalView
		'Ybeg=9
		
		
		if Xbeg>8 then
		ActiveWindow.View = xlPageBreakPreview
		Range("B1:H1").Select
		With Selection
			.HorizontalAlignment = xlCenter
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
	Range("B2:H2").Select
		With Selection
			.HorizontalAlignment = xlCenter
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
	Selection.Merge
	Range("C3:H3").Select
		With Selection
			.HorizontalAlignment = xlLeft
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
		Set ActiveSheet.VPageBreaks(1).Location = Range("I1")
		 
	do	while Xbeg >=3
		'Cells(3,Xbeg).AutoFit
		 columns(Xbeg).EntireColumn.AutoFit
		'Range(Xbeg & "17").AutoFit
		'Columns(Xbeg & ":" & Xbeg).EntireColumn.AutoFit
		Xbeg = Xbeg - 1
    Loop  
	'if Columns("C:C").ColumnWidth+Columns("D:D").ColumnWidth+Columns("E:E").ColumnWidth+Columns("F:F").ColumnWidth+Columns("G:G").ColumnWidth+Columns("H:H").ColumnWidth>85 then
	i=Columns("C:C").ColumnWidth+Columns("D:D").ColumnWidth+Columns("E:E").ColumnWidth+Columns("F:F").ColumnWidth+Columns("G:G").ColumnWidth+Columns("H:H").ColumnWidth
	j=133-i
	Columns("B:B").ColumnWidth=j-3.3
	'end if

	fRange.EntireColumn.Delete  
		Else
		
		ActiveSheet.PageSetup.PrintArea = "$A$1:$H$24"
		
		Range("B1:H1").Select
		With Selection
			.HorizontalAlignment = xlCenter
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
	
	Range("B2:H2").Select
		With Selection
			.HorizontalAlignment = xlCenter
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
	Selection.Merge
	Range("C3:H3").Select
		With Selection
			.HorizontalAlignment = xlLeft
			.VerticalAlignment = xlCenter
			.Orientation = 0
			.AddIndent = False
			.IndentLevel = 0
			.ShrinkToFit = True
			.ReadingOrder = xlContext
			.MergeCells = True
			.WrapText = True
    End With
    Selection.Merge
	
	'i = 28
	do	while Xbeg >=3
		'Cells(3,Xbeg).AutoFit
		 columns(Xbeg).EntireColumn.AutoFit
		'Range(Xbeg & "17").AutoFit
		'Columns(Xbeg & ":" & Xbeg).EntireColumn.AutoFit
		'i=i-3.3
		Xbeg = Xbeg - 1
    Loop  
	'Columns("H:H").ColumnWidth=i
		End If
   ' ActiveWindow.View = xlPageBreakPreview
	 'ActiveWindow.View = xlPageBreakPreview
    'Set ActiveSheet.VPageBreaks(1).Location = Range("I1")
	'Application.PrintCommunication = True
	'    ActiveSheet.PageSetup.PrintArea = "$A$1:$H$24"
	
	 'For sheet1 = 1 To Sheets.Count            
       '     Worksheets(sheet1).Activate
			'Call MergeBySameCells(Xbeg, Ybeg, cntCol, cntRow)
		'set	range1=Worksheets(sheet1).VPageBreaks(1).Location
      '  Next sheet1
      '  Worksheets(1).Activate
	
	ActiveSheet.Unprotect ("admin")
    With ActiveSheet.PageSetup
            .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = True
        .ScaleWithDocHeaderFooter = True
		.FirstPage.RightHeader.Text = "&D"
        .LeftFooter = "&""Times New Roman,обычный""&10" & "________________________________________________" & Chr(10) & "Отчет о результатах КД должностных лиц " & [A3] & " в разрезе видов нарушений"
        .RightFooter = "&""Times New Roman,обычный""&10Страница &P из &N"
                .AlignMarginsHeaderFooter = True
          .LeftMargin = Application.InchesToPoints(0.393)
        .RightMargin = Application.InchesToPoints(0.59375)
        .TopMargin = Application.InchesToPoints(0.787)
        .BottomMargin = Application.InchesToPoints(0.393)
        .HeaderMargin = Application.InchesToPoints(0.314)
        .FooterMargin = Application.InchesToPoints(0.118)
    End With
	
Call AutoFitAllRows


Range("5:5").Select  ' оформление шапки таблицы
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 90
        .AddIndent = False
       .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
       ' Selection.ColumnWidth = 15
       Selection.RowHeight = 110
    End With

Range("A5:C5").Select  ' оформление шапки таблицы
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
       .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With

Range("B1").Select  ' фиксированная область
With ActiveWindow
    .SplitColumn = 2
    .SplitRow = 6
End With
ActiveWindow.FreezePanes = True

    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        ActiveSheet.PageSetup.PrintTitleRows = ActiveSheet.Rows("6:6").Address
        ActiveSheet.PageSetup.PrintTitleColumns = ActiveSheet.Columns("A:A").Address
    End With
    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address

   ' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="admin"'
End Sub