Sub Макрос()
      Dim arr As Variant
      Application.ScreenUpdating = 0: Application.EnableEvents = 0
      With Intersect(ActiveSheet.UsedRange, [A:G])
          .Copy .Offset(, .Columns.Count + 1)
          With .Offset(, .Columns.Count + 1)
              .UnMerge: .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
              .Copy: .PasteSpecial Paste:=xlPasteValues: .ClearFormats
              arr = .Resize(, 1): .Resize(, 1).Value = .Offset(, 4).Resize(, 1).Value
              .Offset(, 4).Resize(, 1).Value = arr: arr = .Offset(, 1).Resize(, 1)
              .Offset(, 1).Resize(, 1).Value = .Offset(, 5).Resize(, 1).Value
              .Offset(, 5).Resize(, 1).Value = arr: arr = .Offset(, 6).Resize(, 1).Value
              .Offset(, 6).Resize(, 1).Value = .Offset(, 2).Resize(, 1).Value
              With .Offset(, 2).Resize(, 1)
                  .Formula = arr: .NumberFormat = "dd.mm.yy hh:mm"
              End With
              .Columns.AutoFit
          End With
      End With
      Application.CutCopyMode = False
      Application.ScreenUpdating = 1: Application.EnableEvents = 1
End Sub

Sub qwe()
      With Application: .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0
          With ActiveWorkbook.Worksheets("Лист1").Sort
              With .SortFields
                  .Clear
                  .Add Intersect([A1].CurrentRegion, [E:E]), 0, 1, 0
                  .Add Intersect([A1].CurrentRegion, [F:F]), 0, 1, 0
                  .Add Intersect([A1].CurrentRegion, [D:D]), 0, 1, 0
              End With
              .SetRange [A1].CurrentRegion
              .Header = xlYes
              .MatchCase = False
              .Orientation = xlTopToBottom
              .SortMethod = xlPinYin
              .Apply
          End With
          Dim col As Range, rcnt&, rnum&: rnum = 2
          With Intersect([A2].CurrentRegion, [E:G], ActiveSheet.UsedRange.Offset(1))
              .Select
              Do
                  On Error Resume Next
                  Selection.ColumnDifferences(ActiveCell).Select
                  rcnt = Selection.Row - rnum: rnum = Selection.Row
                  If rcnt > 1 Then
                      For Each col In .Rows(rnum).Offset(-rcnt - 1).Resize(rcnt).Columns
                          col.Merge
                      Next
                  End If
              Loop Until Err.Number
              If Selection.Rows.Count > 1 Then
                  For Each col In Selection.Columns
                      col.Merge
                  Next
              End If
          End With
          Intersect([A1].CurrentRegion, [D:D]).Cut
          Intersect([A1].CurrentRegion.EntireRow, [H:H]).Insert Shift:=xlToRight
          Intersect([A1].CurrentRegion, [D:G]).Cut
          Intersect([A1].CurrentRegion, [A:A]).Insert Shift:=xlToRight
      .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With
End Sub