'Количество колонок в таблице
Public Const col = 12

Private Sub Отчет_складские_запасы()
'Разделение оплат по компаниям для того, чтобы прсомотреть,
'что покупалось для восстановления запасов
Dim str1 As String, str2 As String
Dim a As Integer, i As Integer, b As Integer, m As Long
Dim lastrow As Long, cel As Long
Dim OldSheet As Object, NewSheet As Object

Application.ScreenUpdating = False
Set OldSheet = Sheets("Все"
Set NewSheet = Sheets.Add
ActiveSheet.Name = "Отчет"
ActiveSheet.Select
ActiveSheet.Move After:=OldSheet

  Формат_столбцов
      
a = 2
Range("B2".Select
Do While ActiveCell.Value <> 0
    str1 = ActiveCell.Value
    str2 = ActiveCell.Offset(1, 0).Value
'*************************************
  If str1 <> str2 Then
     ActiveCell.Offset(1, 0).EntireRow.Select 'm - номер строки
     Selection.Insert Shift:=xlDown
          
     Selection.Borders(xlEdgeLeft).LineStyle = xlNone
     Selection.Borders(xlEdgeRight).LineStyle = xlNone
     Selection.Borders(xlInsideVertical).LineStyle = xlNone
     Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
     
     a = a + 1
  End If
'*************************************
    a = a + 1
    Cells(a, 2).Select ' переход на следующую ячейку
Loop

'Задаем жирную линию границы вставленной таблице
b = Cells(65536, 2).End(xlUp).Row
For i = b To 2 Step -1
    If IsEmpty(Cells(i, 2).Offset(-1, 0)) = True Then
        Cells(i, 2).CurrentRegion.Select
        cel = Selection.Rows.Count
        Cells(i, 2).Resize(cel, col).Select
        
         Формат_таблицы
    End If
Next i

Заголовки_таблицы

Application.ScreenUpdating = True
End Sub

Private Sub Формат_столбцов()
   Dim b As Long
   Set OldSheet = Sheets("Все"
   Set NewSheet = Sheets("Отчет"
   OldSheet.Activate
   OldSheet.Range("B2".Select
   ActiveCell.CurrentRegion.Select
   Selection.Copy

NewSheet.Activate

ActiveSheet.Paste
With Selection
       .MergeCells = False
End With
With ActiveSheet
   Range("A:A".EntireColumn.Delete
   lastrow = Cells(65536, 2).End(xlUp).Row
   Range(.Cells(1, 1), .Cells(lastrow, 13)).Select
   Selection.Sort Key1:=Range("a1", Order1:=xlAscending, Header:=xlGuess, _
           OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
           ataOption1:=xlSortNormal
End With
With NewSheet
    Columns("A:A".ColumnWidth = 20
    Columns("B:B".ColumnWidth = 25
    Columns("C:C".ColumnWidth = 10
    Columns(":D".ColumnWidth = 10
    Columns("E:E".ColumnWidth = 14
    Columns("F:F".ColumnWidth = 11
    Columns("G:G".ColumnWidth = 10
    Columns("H:H".ColumnWidth = 10
    Columns("I:I".ColumnWidth = 2
    Columns("J:J".ColumnWidth = 20
    Columns("K:K".ColumnWidth = 20
    Columns("L:L".ColumnWidth = 20
    Selection.Rows.AutoFit
End With
    Columns("A:A".Select
    Selection.Insert Shift:=xlToRight
    Selection.ColumnWidth = 4

Range("A2".Select
'Удаляем пустые ячейки после форматирования - Апрель 2007, Май 2007 и пр.
b = ActiveSheet.UsedRange.Rows.Count
For i = b To 1 Step -1
    If IsEmpty(Cells(i, 5)) Then
        Cells(i, 5).EntireRow.Delete
    End If
Next i

For i = b To 1 Step -1
    If Not IsEmpty(Cells(i, 7)) Then
        Cells(i, 7).Select
        Selection.Font.Bold = True
    End If
Next i

Rows("1:1".Select
Selection.Insert Shift:=xlDown
    
End Sub

Private Sub Формат_таблицы()
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
'        .LineStyle = xlContinuous
        .Weight = xlThin
'        .ColorIndex = xlAutomatic
End With

End Sub

Private Sub Заголовки_таблицы()
    Range("B1".Value = "Название организации"
    Range("c1".Value = "Назначение платежа"
    Range("d1".Value = "Сумма оплаты, грн."
    Range("f1".Value = "ОКПО"
    Range("g1".Value = "Оплатили:"
    Range("h1".Value = "№ и дата"
    Range("k1".Value = "Цель приобретения, заявитель"
    Range("l1".Value = "Распределение по бюджету"
    Range("b1:M1".Select
    
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
            
    Формат_таблицы
    Объед_яч
End Sub

Private Sub Объед_яч()
    Range("1:E1".Select
    With Selection
        .MergeCells = False
    End With
    Selection.Merge
    
    Range("H1:I1".Select
    With Selection
        .MergeCells = False
    End With
    Selection.Merge
    
    Range("L1:M1".Select
    With Selection
        .MergeCells = False
    End With
    
    Selection.Merge
    Rows("2:2".Select
    ActiveWindow.FreezePanes = True
    
    ActiveWindow.Zoom = 90
    Range("B2".Select
End Sub
Public Sub Вход()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Dim bolA As Boolean
On Error Resume Next
bolA = Worksheets("Отчет".Activate

If bolA Then
    Msg = "Удалить лист Отчет и сформировать новый?"
    Style = vbYesNo + vbQuestion + vbDefaultButton2
    Title = "Внимание!"
    Help = "EMO.HLP"
    Ctxt = 1000
    
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
      If Response = vbYes Then
      Application.DisplayAlerts = False
      Worksheets("Отчет".Delete
      Application.DisplayAlerts = True
      
      Отчет_складские_запасы
        Else: Exit Sub
      End If
Else: Отчет_складские_запасы
End If
End Sub