Option Explicit
Sub форматы()

Dim myDoc1, myDocres As Worksheet
Dim cel1 As Range, celres As Range
Dim i&, j&, ii&, jj&
Dim lLastRow, lLastCol As Long

With Application
           .DisplayAlerts = False
           .Calculation = xlCalculationManual
           .ScreenUpdating = False
           .EnableEvents = False
              
Sheets(3).Activate

lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
Set myDoc1 = ActiveSheet
Set myDocres = Worksheets(1)
Set celres = myDocres.UsedRange
Set cel1 = myDoc1.Range(Cells(1, 1), Cells(lLastRow, lLastCol))

For i = 1 To lLastRow
For j = 1 To lLastCol
celres.Cells(i, j).Font.Name = cel1.Cells(i, j).Font.Name
celres.Cells(i, j).Font.Size = cel1.Cells(i, j).Font.Size
celres.Cells(i, j).Font.Color = cel1.Cells(i, j).Font.Color
celres.Cells(i, j).Font.Bold = cel1.Cells(i, j).Font.Bold
celres.Cells(i, j).Font.Italic = cel1.Cells(i, j).Font.Italic
celres.Cells(i, j).NumberFormat = cel1.Cells(i, j).NumberFormat
          
celres.Cells(i, j).HorizontalAlignment = cel1.Cells(i, j).HorizontalAlignment
celres.Cells(i, j).VerticalAlignment = cel1.Cells(i, j).VerticalAlignment
celres.Cells(i, j).Interior.Color = cel1.Cells(i, j).Interior.Color

celres.Cells(i, j).Borders(xlEdgeLeft).LineStyle = cel1.Cells(i, j).Borders(xlEdgeLeft).LineStyle
celres.Cells(i, j).Borders(xlEdgeRight).LineStyle = cel1.Cells(i, j).Borders(xlEdgeRight).LineStyle
celres.Cells(i, j).Borders(xlEdgeTop).LineStyle = cel1.Cells(i, j).Borders(xlEdgeTop).LineStyle
celres.Cells(i, j).Borders(xlEdgeBottom).LineStyle = cel1.Cells(i, j).Borders(xlEdgeBottom).LineStyle
celres.Cells(i, j).Borders(xlInsideVertical).LineStyle = cel1.Cells(i, j).Borders(xlInsideVertical).LineStyle
celres.Cells(i, j).Borders(xlInsideHorizontal).LineStyle = cel1.Cells(i, j).Borders(xlInsideHorizontal).LineStyle
          
celres.Cells(i, j).Borders(xlEdgeLeft).Weight = cel1(i, j).Borders(xlEdgeLeft).Weight
celres.Cells(i, j).Borders(xlEdgeRight).Weight = cel1(i, j).Borders(xlEdgeRight).Weight
celres.Cells(i, j).Borders(xlEdgeTop).Weight = cel1(i, j).Borders(xlEdgeTop).Weight
celres.Cells(i, j).Borders(xlEdgeBottom).Weight = cel1(i, j).Borders(xlEdgeBottom).Weight
celres.Cells(i, j).Borders(xlEdgeLeft).Weight = cel1(i, j).Borders(xlEdgeLeft).Weight
celres.Cells(i, j).Borders(xlEdgeLeft).Weight = cel1(i, j).Borders(xlEdgeLeft).Weight

celres.Cells(i, j).Borders(xlEdgeLeft).Color = cel1.Cells(i, j).Borders(xlEdgeLeft).Color
celres.Cells(i, j).Borders(xlEdgeRight).Color = cel1.Cells(i, j).Borders(xlEdgeRight).Color
celres.Cells(i, j).Borders(xlEdgeTop).Color = cel1.Cells(i, j).Borders(xlEdgeTop).Color
celres.Cells(i, j).Borders(xlEdgeBottom).Color = cel1.Cells(i, j).Borders(xlEdgeBottom).Color
celres.Cells(i, j).Borders(xlInsideVertical).Color = cel1.Cells(i, j).Borders(xlInsideVertical).Color
celres.Cells(i, j).Borders(xlInsideHorizontal).Color = cel1.Cells(i, j).Borders(xlInsideHorizontal).Color

On Error Resume Next
If cel1(i, j).HasFormula Then
Worksheets(1).Cells(i, j).Formula = cel1(i, j).Formula
Else
If Not IsEmpty(Cells(i, j)) Then
If Not cel1(i, j).HasFormula Then
If cel1(i, j) = Sheets(2).Cells(i, j) Then
If cel1(i, j).Value = Worksheets(4).Cells(i, j).Value Then
If cel1(i, j).Value = Worksheets(5).Cells(i, j).Value Then
celres.Cells(i, j).Value = cel1(i, j).Value

End If
End If
End If
End If
End If
End If

Next j
Next i

For i = 1 To lLastRow
For j = 1 To lLastCol
If cel1(i, j).MergeCells = True Then
ii = cel1.MergeArrear.Rows.Count
jj = cel1.MergeArrear.Columns.Count
celres(Cells(i, j), Cells(ii, jj)).MergeCells
End If
Next j
Next i

For j = 1 To lLastCol
celres.Columns(j).ColumnWidth = cel1.Columns(j).ColumnWidth
Next j
For i = 1 To lLastRow
celres.Rows(i).RowHeight = cel1.Rows(i).RowHeight
Next i
myDocres.Activate
ActiveWindow.Zoom = 75
           .ScreenUpdating = True
           .EnableEvents = True
           .Calculation = True
           .DisplayAlerts = True
End With
Application.ErrorCheckingOptions.UnlockedFormulaCells = False
End Sub

Sub Макрос_объединенных_ячеек()
Dim iFirstRow, iLastRow, lLastRow, lLastCol, iFirstCol, iLastCol1 As Long
Dim myDoc1, myDocres As Worksheet
Dim Cel1 As Range, celres, cel1M As Range
Dim i&, j&, ii&, jj&
Dim iLastCol As String
Set myDocres = Worksheets(1)
Set myDoc1 = ThisWorkbook.Worksheets(3)
Set celres = myDocres.UsedRange
Set Cel1 = myDoc1.UsedRange
With ThisWorkbook.Worksheets(3) '.Activate
lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
For i = 1 To lLastRow
For j = 1 To lLastCol
Set cel1M = Cel1(i, j)
If cel1M.MergeCells Then
myDocres.Range(cel1M.MergeArea.Address).Merge
ii = cel1M.MergeArea.Columns.Count
jj = cel1M.MergeArea.Rows.Count
iFirstRow = Replace(Split(cel1M.MergeArea.Address, "$")(2), ":", "")
iLastRow = Split(cel1M.MergeArea.Address, "$")(4)
iFirstCol = Replace(Split(cel1M.MergeArea.Address, "$")(1), ":", "")
iLastCol = Split(cel1M.MergeArea.Address, "$")(3)
If jj > 1 Then
If ii > 1 Then
MsgBox "адрес ячейки " & cel1M.MergeArea.Address
MsgBox "Ячейка " & cel1M.Address(0, 0) & " объеденена с ячеки " & iFirstCol & iFirstRow & " по ячеку " & iLastCol & iLastRow, 64, ""
MsgBox "всего колонок " & ii
MsgBox "всего рядов " & jj
Else
MsgBox "адрес ячейки " & cel1M.MergeArea.Address
MsgBox "Ячейка " & cel1M.Address(0, 0) & " объеденена с " & iFirstRow & " по " & iLastRow & " ряд", 64, ""
MsgBox "всего рядов " & jj
End If
End If
If jj = 1 Then
If ii > 1 Then
MsgBox "адрес ячейки " & cel1M.MergeArea.Address
MsgBox "всего колонок " & ii
MsgBox "Ячейка " & cel1M.Address(0, 0) & " объеденена с колонки " & iFirstCol & " по колонку " & iLastCol, 64, ""
End If
End If
Else
MsgBox "Ячейка " & cel1M.Address & "не объединена!", 48, ""
End If
Next j
Next i
End With
End Sub