Придётся отменять объединение ячеек и заполнять пустые строки. Как это делается, можно посмотреть здесь или почитать здесь Тогда сводная построится без проблем
Придётся отменять объединение ячеек и заполнять пустые строки. Как это делается, можно посмотреть здесь или почитать здесь Тогда сводная построится без проблемPelena
Ну, видимость объединения можно оставить, например, если выполнить подобный макрос, то пустых ячеек не будет, но объединение останется [vba]
Код
Sub dd() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 With Sheets("Ëèñò1") .Copy Sheets(1) With .[A1].CurrentRegion .UnMerge On Error Resume Next .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" On Error GoTo 0 Sheets(1).Range(.Address).Copy .PasteSpecial xlPasteFormats Sheets(1).Delete End With End With .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
[/vba]
Ну, видимость объединения можно оставить, например, если выполнить подобный макрос, то пустых ячеек не будет, но объединение останется [vba]
Код
Sub dd() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 With Sheets("Ëèñò1") .Copy Sheets(1) With .[A1].CurrentRegion .UnMerge On Error Resume Next .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" On Error GoTo 0 Sheets(1).Range(.Address).Copy .PasteSpecial xlPasteFormats Sheets(1).Delete End With End With .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
Sub test() Dim data, lr&, i&, j&, d As Date, prod$ Dim dicDate As Object, dicProduct As Object, dicTemp As Object, kDate, kProd Dim inp As Worksheet, res As Worksheet
Set inp = ThisWorkbook.Sheets(1) Set res = ThisWorkbook.Sheets(2)
With inp.[a1].CurrentRegion data = .Offset(1).Resize(.Rows.Count - 1).Value End With Set dicDate = CreateObject("scripting.dictionary") Set dicProduct = CreateObject("scripting.dictionary")
For i = 1 To UBound(data, 1) If data(i, 1) <> "" Then prod = data(i, 1) If data(i, 2) <> "" Then d = data(i, 2) If dicDate.exists(d) Then dicDate.Item(d).Item(prod) = dicDate.Item(d).Item(prod) + data(i, 4) Else Set dicTemp = CreateObject("scripting.dictionary") dicTemp(prod) = data(i, 4) Set dicDate.Item(d) = dicTemp End If dicProduct(prod) = i Next i
With res .UsedRange.ClearContents .[a2].Resize(dicDate.Count) = Application.Transpose(dicDate.keys) .[b1].Resize(, dicProduct.Count) = dicProduct.keys i = 2 For Each kDate In dicDate.keys For j = 1 To dicProduct.Count .Cells(i, j + 1) = dicDate.Item(kDate).Item(Trim(.Cells(1, j + 1))) Next j i = i + 1 Next kDate End With End Sub
[/vba] Результат см. на листе "Результат"
Вариант решения макросом: [vba]
Код
Sub test() Dim data, lr&, i&, j&, d As Date, prod$ Dim dicDate As Object, dicProduct As Object, dicTemp As Object, kDate, kProd Dim inp As Worksheet, res As Worksheet
Set inp = ThisWorkbook.Sheets(1) Set res = ThisWorkbook.Sheets(2)
With inp.[a1].CurrentRegion data = .Offset(1).Resize(.Rows.Count - 1).Value End With Set dicDate = CreateObject("scripting.dictionary") Set dicProduct = CreateObject("scripting.dictionary")
For i = 1 To UBound(data, 1) If data(i, 1) <> "" Then prod = data(i, 1) If data(i, 2) <> "" Then d = data(i, 2) If dicDate.exists(d) Then dicDate.Item(d).Item(prod) = dicDate.Item(d).Item(prod) + data(i, 4) Else Set dicTemp = CreateObject("scripting.dictionary") dicTemp(prod) = data(i, 4) Set dicDate.Item(d) = dicTemp End If dicProduct(prod) = i Next i
With res .UsedRange.ClearContents .[a2].Resize(dicDate.Count) = Application.Transpose(dicDate.keys) .[b1].Resize(, dicProduct.Count) = dicProduct.keys i = 2 For Each kDate In dicDate.keys For j = 1 To dicProduct.Count .Cells(i, j + 1) = dicDate.Item(kDate).Item(Trim(.Cells(1, j + 1))) Next j i = i + 1 Next kDate End With End Sub