Есть данные: Дата (по дням, с 2018 года по наше время), Событие (5 событий) и Фамилия (58 фамилий). Все это вертикально без какой либо системы, может не быть события, может сразу несколько, может 1 такое, а 2 других. Сломала голову, как их привести к какой-то возможности использовать в вычислениях. Нужен горизонтальный временной ряд, а вертикально - Фамилии, на клетках пересечения - разнести суммы событий, желательно, чтобы задать, например сумма 1+2+3 событий. Ну или хотя бы просто сумма однотипного события, я их отсортирую по разным. События представлены не в цифре, а в названии, одна строчка - одно событие. В примере, серым - это то, что я вручную разнесла. На многие даты вообще нет событий. Помогите, пожалуйста, кто знает, может в PQ? Или в "умных" как-то, vba совсем не знаю
Option Explicit
Sub ВертГориз()
Dim sh1 As Worksheet
Set sh1 = Worksheets(1)
Dim dic1 As Object
Set dic1 = CreateObject("Scripting.Dictionary")
Dim dic2 As Object
Set dic2 = CreateObject("Scripting.Dictionary")
Dim arr As Variant
GetDic sh1, dic1, dic2, arr
Dim u As Long
Dim y As Long
Dim x As Integer
Dim brr As Variant
ReDim brr(1 To dic1.Count + 1, 1 To dic2.Count + 1)
For u = 0 To dic1.Count - 1
brr(dic1.Items()(u), 1) = dic1.Keys()(u)
Next
For u = 0 To dic2.Count - 1
brr(1, dic2.Items()(u)) = dic2.Keys()(u)
Next
For u = 2 To UBound(arr, 1)
y = dic1.Item(arr(u, 3))
x = dic2.Item(arr(u, 1))
brr(y, x) = brr(y, x) + 1
Next
With Workbooks.Add(1)
.Sheets(1).Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
.Saved = True
End With
End Sub
Private Function GetDic(sh As Worksheet, dic1 As Object, dic2 As Object, arr As Variant) As Boolean
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y, 3))
End With
Set sh = Workbooks.Add(1).Sheets(1)
Dim brr As Variant
Dim u As Integer
sh.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
With sh.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("C2:C" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
' .SortFields.Add Key:=Range("B2:B" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & y)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
brr = sh.Cells(1, 3).Resize(y, 1)
u = 1
For y = 2 To UBound(brr, 1)
If Not dic1.Exists(brr(y, 1)) Then
u = u + 1
dic1.Item(brr(y, 1)) = u
End If
Next
'----------------------------------------------------------------------------------------------------------
sh.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
With sh.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
' .SortFields.Add Key:=Range("B2:B" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & y)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
brr = sh.Cells(1, 1).Resize(y, 1)
u = 1
For y = 2 To UBound(brr, 1)
If Not dic2.Exists(brr(y, 1)) Then
u = u + 1
dic2.Item(brr(y, 1)) = u
End If
Next
sh.Parent.Close False
End Function
формулами выделите F2:F59 за крестик и вправо - но довольно неслабо тормозит и вес с этими формулами при протяжке более 300 Кб Для данного файла на что двссыл заменить подскажите
gling, Спасибо большое, результат замечательный, никак не получается сетку на поле сделать, делаю через Конструктор - Создать стиль сводной таблицы - Вся таблица - Формат - Граница - Выбор линии - ок... и ничего, не знаете, в чем дело?
gling,И еще раз, большое спасиба, замечательный инструмент эти сводные таблицы, как оказалось, я добавила "месяцы", и теперь сразу все суммирует, пуся такая. Завтра уже настоящую таблицу буду мучить, там 38000 строк