Attribute VB_Name = "JCertifK1"
Sub JCertifK1Edit()
    Range("A3").Select
    With ActiveCell.Characters(Start:=1, Length:=24).Font
        .Name = "Times New Roman"
        .FontStyle = "полужирный"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A4").Select
    With ActiveCell.Characters(Start:=1, Length:=17).Font
        .Name = "Times New Roman"
        .FontStyle = "полужирный"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A5").Select
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Times New Roman"
        .FontStyle = "полужирный"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A6:J6").Select
     With ActiveSheet.PageSetup 
         .LeftHeader = "&""Times New Roman,обычный""&12"&"Продолжение Журнала регистрации распоряжений (приказов), удостоверений на право проведения контрольных мероприятий" 
       .CenterFooter = "&""Times New Roman,обычный""&12" &"&P" 
	.OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = True
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .FirstPage.LeftHeader.Text = ""
	.FirstPage.CenterFooter.Text = "&""Times New Roman,обычный""&12" & "&P" 
	.FirstPage.RightHeader.Text = "&""Times New Roman,обычный""&12" & "&D   "
      End With 
	  Call Macros1
End Sub

Sub Macros1()
  Dim shCur As Worksheet
  Dim sh1 As Worksheet
  Dim r0, r1 As Range
  Dim val As String
  Dim width1, width2, h As Double
  Dim newH, oldH As Double
  Dim curRow, curCol, r, i As Integer
  Dim Xbeg, Ybeg, fCol As Integer
  Dim fRange As Range
  fCol = 0
    Ybeg = 0
    'Euai ia?aeuio? eieiieo ii oaenoo "Top_Cells"
    Set fRange = ActiveSheet.Cells.Find(What:="Top_Cells", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                        
        If Not fRange Is Nothing Then
            'Aa??i neo?ae, eiaaa yoi aa?oiyy y?aeea io aeaiiciia, eioi?ue ?aciii?aaony ii no?ieai e noieaoai
            'Iiyoiio i?eaaeyai e iae 1 no?ieo e 1 eieiieo
            If fRange.MergeCells = True Then
                Xbeg = fRange.MergeArea.Cells.Column + fRange.MergeArea.Cells.Columns.Count
                Ybeg = fRange.MergeArea.Cells.Row + fRange.MergeArea.Cells.Rows.Count
            Else
                Xbeg = fRange.Cells.Column
                Ybeg = fRange.Cells.Row + 1
            End If
                            
            'fRange.Value = ""
            fRange.Replace What:="Top_Cells", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        Else
            Xbeg = 1
            Ybeg = 1
        End If
    
                                                    
        'Euai eiia?io? eieiieo ii oaenoo "end_Cells"
        Set fRange = ActiveSheet.Cells.Find(What:="end_Cells", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                        
        If Not fRange Is Nothing Then
            fCol = fRange.Row - 1
                            
            'fRange.Value = ""
            fRange.Replace What:="end_Cells", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If
   
  ' ActiveCell.Cells(Ybeg, 11) = Ybeg
   ' ActiveCell.Cells(fCol, 11) = fCol
  
Application.ScreenUpdating = False

    r = Ybeg 
  Set shCur = ThisWorkbook.Sheets(1)
  
  Do While r <= fCol
  
  Set r0 = Sheets("Лист1").Cells(r, 7)
  If r0.MergeCells = false Then
   'Call AutoFitAllRows
  ' else 
  val = r0.Value
  curRow = r0.Row
  curCol = r0.Column
   
  On Error Resume Next
  Set sh1 = Worksheets("List123")
  If sh1 Is Nothing Then
    'Sheets.Add After:=Sheets(Sheets.Count)
    'Worksheets.Add.Name = "List123"
    'sh1 = Worksheets("List123")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "List123"
  End If
  
  Set r1 = sh1.Cells(1, 1)
  r1.Font.Name = r0.Font.Name
  r1.Font.Size = r0.Font.Size
  r1.Font.Bold = r0.Font.Bold
  
  r1.Value = val
  
  width1 = r0.ColumnWidth
  r1.ColumnWidth = width1
  
  
  r1.HorizontalAlignment = xlLeft
  r1.VerticalAlignment = xlTop
  r1.WrapText = True
    r1.EntireRow.AutoFit
  r1.EntireColumn.AutoFit
  width2 = r1.ColumnWidth
  
  If width2 < width1  Then
 If width1 - width2 <= 3 Then
    r0.ColumnWidth = width1 + 1
    r0.EntireRow.AutoFit
    r0.ColumnWidth = width1
    Else
	'If width1 - width2 = 2 Then
	'r1.RowHeight=r0.RowHeight
   ' r0.EntireRow.AutoFit
  '  r0.ColumnWidth = width1
	'else 
	'If width1 - width2 > 20 Then
	'r0.EntireRow.AutoFit
	'else
    r0.ColumnWidth = width1 + (width1 - width2)
   ' r0.EntireRow.AutoFit
	r0.RowHeight = r1.RowHeight
    r0.ColumnWidth = width1
	'End If
  End If
  
  End If
   If width1 < width2  Then
    'r0.ColumnWidth = width2
	r0.RowHeight = r1.RowHeight
   ' r0.ColumnWidth = width1
	'End If
 ' End If
  
  End If
  ' newH = r0.RowHeight
  ' else 
  ' r0.EntireRow.AutoFit
   End If
   r = r + 1
    'ActiveCell.Cells(fCol, 11) = width1
	
Loop
    Sheets("Лист1").Select
	Application.DisplayAlerts = False 
   sh1.Delete
    'ActiveWindow.SelectedSheets.Delete
  Application.ScreenUpdating = True
End Sub

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