Sub RaznestiDannye()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim iLR_old As Long
Dim n As Long
Dim iLastCol As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Dim iSht As Worksheet
Dim j As Integer
Application.ScreenUpdating = False
Set Sht = ThisWorkbook.Worksheets("Общ")
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Rows(iLastRow + 1).Delete 'удаляем строку с суммами в F:I
'количество значений групп (Шпон, Файн и т.д.)
n = Cells(1, "J").End(xlDown).Row
For i = 1 To n 'цикл по значениям
Criterij = Sht.Cells(i, "J") 'очередная группа
iName = Criterij 'имя очередного листа
'ставим автофильтр по столбцу J
Sht.Range("B14:J" & iLastRow).AutoFilter 9, Criterij
Set iSht = Worksheets(iName)
With iSht 'очередной лист соотв.группы
iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column 'посл.столбец по строке 3
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
If iLR < 4 Then iLR = 4
.Range("B4:I" & iLR).Clear 'очищаем данные на соотв.листе
'копируем видимые строки без шапки в соответств. лист
Sht.AutoFilter.Range.Offset(1).Columns("A:H").SpecialCells(xlCellTypeVisible).Copy
.Range("B4").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Activate
.Range("B4").Select
iLR = Cells(Rows.Count, "B").End(xlUp).Row 'посл.строка в столбце В
If iLR < 4 Then iLR = 4 'не учитывая строк Сумма и Сальдо
iLR_old = Cells(Rows.Count, "J").End(xlUp).Row 'предыдущ.посл.строка в столбце J
'с учетом строк Сумма и Сальдо
Range("B4:I" & iLR + 2).Borders.Weight = xlThin 'границы таблицы
Range(Cells(iLR + 1, "B"), Cells(iLR + 2, iLastCol)).ClearContents
Cells(iLR + 1, "B") = "Итого" 'вставляем Итого, Сальдо и считаем
Cells(iLR + 2, "B") = "Сальдо" 'соответств. суммы
Cells(iLR + 1, "F").Formula = "=Sum(F4:F" & iLR & ")" 'сумма по F
Cells(iLR + 1, "G").Formula = "=Sum(G4:G" & iLR & ")" 'сумма по G
Cells(iLR + 1, "H").Formula = "=Sum(H4:H" & iLR & ")" 'сумма по H
Cells(iLR + 1, "I").Formula = "=Sum(I4:I" & iLR & ")" 'сумма по I
Cells(iLR + 2, "F").Formula = "=F" & iLR + 1 & "- H" & iLR + 1
Cells(iLR + 2, "G").Formula = "=G" & iLR + 1 & "- I" & iLR + 1
'формулы для столбцов J:M строка Итого iLR + 1
Cells(iLR + 1, "J").Formula = "=F" & iLR + 1 & "- N" & iLR + 1
Cells(iLR + 1, "K").Formula = "=G" & iLR + 1 & "- O" & iLR + 1
Cells(iLR + 1, "L").Formula = "=H" & iLR + 1 & "- P" & iLR + 1
Cells(iLR + 1, "M").Formula = "=I" & iLR + 1 & "- Q" & iLR + 1
'формулы для столбцов J:M строка Сальдо iLR + 2
Cells(iLR + 2, "J").Formula = "=J" & iLR + 1 & "- L" & iLR + 1
Cells(iLR + 2, "K").Formula = "=K" & iLR + 1 & "- M" & iLR + 1
Cells(iLR + 2, "L").Formula = "=H" & iLR + 2 & "- P" & iLR + 2
Cells(iLR + 2, "M").Formula = "=I" & iLR + 2 & "- Q" & iLR + 2
'копируем диапазон с формулами сумм F:I до iLastCol - 3
For j = 14 To iLastCol - 3 Step 4
Range(Cells(iLR + 1, "F"), Cells(iLR + 1, "I")).Copy Cells(iLR + 1, j)
Next
'проверяем число строк iLR и сравниваем с предыдущим значением iLR_old
If iLR + 2 >= iLR_old Then 'копируем формулы с строки iLR_old -2
'убираем старую заливку строк Итого и Сальдо от столбца J и правее
Range(Cells(iLR_old - 1, "J"), Cells(iLR_old, iLastCol)).Interior.ColorIndex = xlNone
Range(Cells(iLR_old - 2, "J"), Cells(iLR_old - 2, iLastCol)).Copy
Range(Cells(iLR_old - 1, "J"), Cells(iLR, iLastCol)).PasteSpecial xlPasteFormulas
Else
Rows(iLR + 3 & ":" & iLR_old).Delete 'удаляем лишние строки
End If
Range(Cells(iLR + 1, "F"), Cells(iLR + 2, "M")).NumberFormat = "#,##0.000"
Range(Cells(iLR + 1, "F"), Cells(iLR + 1, iLastCol)).NumberFormat = "#,##0.000"
Range(Cells(iLR + 1, "B"), Cells(iLR + 2, iLastCol)).Interior.ColorIndex = 15
Cells(iLR + 1, "B").Activate
End With
Sht.Activate 'активируем лист Общ
Sht.AutoFilter.Range.AutoFilter 'возвращаем все значения автофильтра
Next
Application.ScreenUpdating = True
End Sub |