If tbl.DataBodyRange Is Nothing Then  

Sub CopyTest3()
    Dim sPath As String, sName As String
    sPath = ActiveWorkbook.Path
    sName = ActiveSheet.Name
    ActiveSheet.Copy Before:=Sheets(1)
    Sheets(1).UsedRange.Value = Sheets(1).UsedRange.Value
    Sheets(1).Move
    ActiveSheet.Name = sName
    ActiveWorkbook.SaveAs sPath & "\" & sName & ".xlsx", 51
    ActiveWorkbook.Close
End Sub

Sub qq()
    Dim lr&, lrow&, i&, j&, k&
    lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Range("A1").Resize(lr).AutoFilter Field:=1, Criteria1:="<>"
    k = 1: j = 4
    For i = 2 To lr
        If IsDate(Range("A" & i)) Or i = lr Then
            lrow = Cells(Rows.Count, j).End(xlUp).Row + 1
            If lrow = 2 Then lrow = 1
            Range("A" & k & ":A" & i - 1).Copy Cells(lrow, j)
            k = i
            j = j + 1
            If j > 6 Then j = 4
        End If
    Next
End Sub

Sub lknb()

'просуммировать значения в нарастании по ключам
Dim d1 As Object, i As Integer, j As Integer
Dim a, b, c

'пилим словарь
Set d1 = CreateObject("scripting.dictionary")

'массив с нарастающим итогом
a = Range("a4").CurrentRegion
'массив сттатей, которые попадут в нарастающий итог
b = Range("d4").CurrentRegion

'For i = 1 To UBound(a, 1)
'    d1.Add a(i, 1), 0
'Next

'прохожусь по статьям в массиве b. Если есть ключ сущестует, тогда
'к итему с 0 суммой прибавляется сумма привязанная к этому ключу
For i = 1 To UBound(b, 1)
'    If d1.Exists((a(1, 1))) Then d1(a(1, 1)) = d1(a(1, 1)) + b(i, 2)
    d1.Item(b(i, 1)) = d1.Item(b(i, 1)) + b(i, 2)
Next

'массив для вставки сложенных в нарастании итемов (сумм) по ключам
'ReDim c(1 To UBound(a, 1), 1 To 1)

'c = d1(a(1, 1))
c = d1.Items

Stop
End Sub