Sub RollingData()
'
' Макрос1 Макрос
' Макрос записан 14.01.2009 (user)
'

'
Dim sCurrentFiltRange As String
Dim r As Range
Dim s As Worksheet, sh As Worksheet, shOut As Worksheet, w As Workbook, w1 As Workbook
Dim vPriznak As Variant
Dim vMonth As Variant
Dim vGroup As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set w = Application.ActiveWorkbook
Set sh = Worksheets("филиал")
sCurrentFiltRange = sh.AutoFilter.Range.Address

Set w1 = Application.Workbooks.Add
Application.DisplayAlerts = False
w1.PrecisionAsDisplayed = True
w1.Worksheets("Лист1").Delete
w.Worksheets("Результат").Delete
Application.DisplayAlerts = True

Set s = w1.Worksheets.Add
s.Name = "Лист1"
Set s = Nothing

Set s = w.Worksheets.Add
s.Name = "Результат"

' Получаем список уникальных комбинаций из
' признак филиал-Укрнафта или ещё какой-то,
' месяца оплаты, номера платёжного поручения,
' группы, вида и суммы оплаты
Set r = Worksheets("Лист1").Range("a1")
sh.Range("P:U").AdvancedFilter xlFilterCopy, , r, True
Application.DisplayAlerts = False
w1.PrecisionAsDisplayed = False
DoEvents
w1.PrecisionAsDisplayed = True
vGroup = r.Range("a2:F" + CStr(r.SpecialCells(xlCellTypeLastCell).Row -  1 )).Value2
Application.DisplayAlerts = True

w.Activate
s.Select
Dim iPriz As Long, iMonth As Long, iGr As Long, i As Long, nCurrRow As Long, bFirst As Boolean
nCurrRow =  2 
Dim ar As Areas
For iGr = LBound(vGroup) To UBound(vGroup)
    With sh.Range(sCurrentFiltRange)

        .AutoFilter Field:= 16 , Criteria1:=CStr(vGroup(iGr,  1 )) '"январь"
        .AutoFilter Field:= 17 , Criteria1:=CStr(vGroup(iGr,  2 )) '"филиал"
        .AutoFilter Field:= 18 , Criteria1:=CStr(vGroup(iGr,  3 )) '№ платежки
        .AutoFilter Field:= 19 , Criteria1:=CStr(vGroup(iGr,  4 )) '"группа"
        .AutoFilter Field:= 20 , Criteria1:=CStr(vGroup(iGr,  5 )) '"статья"
        .AutoFilter Field:= 21 , Criteria1:=Replace(Trim(Format(vGroup(iGr,  6 ), "#,##0.00")), ",", ".") 
'w1.Worksheets("Лист1").Cells(iGr + 1, 5) 'Trim(Format(vGroup(iGr, 5), "#,##0.00"))   '"62,76"
        'DoEvents
        For Each r In sh.Range(sCurrentFiltRange).SpecialCells(xlCellTypeVisible).Areas
            i = i + r.Rows.Count ' .SpecialCells(xlCellTypeVisible).Rows.Count
        Next r
        If i >  1  Then
            bFirst = True
            For Each r In sh.Range(sCurrentFiltRange).SpecialCells(xlCellTypeVisible).Areas
                If r.Rows.Count >  1  Or Not bFirst Then
                    r.Rows( 1  + - 1  * CLng(bFirst)).Copy
                    s.Select
                    s.Rows(nCurrRow).Select
                    s.Paste
                    s.Cells(nCurrRow,  21 ).Value = "=" + Replace(CStr(s.Cells(nCurrRow,  21 ).Value), ",", ".") + "*" + 
CStr(i -  1 )
                    s.Cells(nCurrRow,  31 ).Value = CStr(i -  1 )
                    nCurrRow = nCurrRow +  1 
                    Exit For
                Else
                    bFirst = False
                End If
            Next r
        Else
            i = i
        End If
        Debug.Print i -  1 , Round(CDbl(vGroup(iGr,  6 )),  2 ), CStr(vGroup(iGr,  1 )), CStr(vGroup(iGr,  2 )), CStr(vGroup(iGr, 
 3 )), CStr(iGr)
        i =  0 
    End With
Next iGr
' Отключаем автофильтры
sh.ShowAllData
' Закрываем книгу с уникальным списком
sCurrentFiltRange = w1.Name
Set w1 = Nothing
Application.DisplayAlerts = False
Application.Workbooks(sCurrentFiltRange).Close (False)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Закончили!"
End Sub