Option Explicit

Private Sub Svertka()
'
' Макрос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

On Error GoTo labErr

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Запоминаем текущую книгу и лист. Они считаются исхолдными данными
Set w = Application.ActiveWorkbook
Set sh = Application.ActiveSheet
' Проверяем наличие автофильтра, можно устанавливать самому, но ...
If sh.AutoFilter Is Nothing Then
    MsgBox "Установите автофильтр"
    Exit Sub
End If
' Получаем адрес используемого в автофильтре диапазона
sCurrentFiltRange = sh.AutoFilter.Range.Address
' Добавляем новую книгу для сохранения результатов
Set w1 = Application.Workbooks.Add
Application.DisplayAlerts = False
w1.PrecisionAsDisplayed = True
Application.DisplayAlerts = True

' Добавляем в новую книгу два листа, для списка уникальных значений автофильтра и для конечного результата
CheckSheet w1, "Уникальные"
Set s = CheckSheet(w, "Результат") 'w.Worksheets.Add

' Копируем "шапку" данных из источника в результат
w.Activate
sh.Rows( 1 ).Copy
s.Select
s.Rows( 1 ).Select
s.Paste
s.Range("AD1").Value = "Пустое"
s.Range("AE1").Value = "Количество записей в оригинале"

' Получаем список уникальных комбинаций из
' признак филиал-Укрнафта или ещё какой-то,
' месяца оплаты, номера платёжного поручения,
' группы, вида и суммы оплаты
Set r = w1.Worksheets("Уникальные").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)).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 )) '"п.01 Группа платежа"
        .AutoFilter Field:= 20 , Criteria1:=CStr(vGroup(iGr,  5 )) '"пп.01.1 Статья платежа"
        .AutoFilter Field:= 21 , Criteria1:=Replace(Trim(Format(vGroup(iGr,  6 ), "#,##0.00000")), ",", ".") ' сумма
        'Подсчитываем общее количество по автофильтру
        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
        pBar.Value = pBar.Value +  1 
        pBar.Refresh
'        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
pBar.Value = pBar.Value +  1 
If nCurrRow >  2  Then
' Строим сводную для проверки
'    Call CreatePivotTables(sh, sCurrentFiltRange, s, "A1:AE" + CStr(nCurrRow - 1))
End If
sCurrentFiltRange = w1.Name
Set w1 = Nothing
Application.DisplayAlerts = False
' Закрываем книгу с уникальным списком
Application.Workbooks(sCurrentFiltRange).Close (False)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
pBar.Value = pBar.Value +  1 
pBar.Value = pBar.Max
If nCurrRow >  2  Then
    MsgBox "Закончили!"
Else
    MsgBox "Нет данных для обработки, данные не обработаны!", vbCritical + vbOKOnly
End If
Exit Sub
labErr:
sCurrentFiltRange = w1.Name
Set w1 = Nothing
Application.DisplayAlerts = False
Application.Workbooks(sCurrentFiltRange).Close (False)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Что-то не получилось, данные не обработаны! Ошибка - " & Err.Description, vbCritical + vbOKOnly
End Sub

Private Function CheckSheet(w As Workbook, sName As String, Optional bCreate As Boolean = True) As Worksheet
Dim b As Boolean
b = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error GoTo labErr
' Если есть лист пытаемся удалить его
w.Sheets(sName).Delete
If bCreate Then
' Если удалили и нужно создавать, создаем и возвращаем
    Set CheckSheet = w.Sheets.Add
    CheckSheet.Name = sName
End If
Application.DisplayAlerts = b
Exit Function
labErr:
Application.DisplayAlerts = b
If bCreate Then
' Если нужно создавать, создаем и возвращаем
    Set CheckSheet = w.Sheets.Add
    CheckSheet.Name = sName
End If
End Function