Суммеслимн в VBA, аналог сводной таблицы

@tyler14 · Регистрация: 29.06.2017

Студворк — интернет-сервис помощи студентам

Добрый день!
Есть лист с данными в виде таблицы.
По ключевым столбцам нужно сформировать подобие сводной.

Попытался использовать следующий код. Во вложении то, что получилось, а также лист с тем, что хотелось бы иметь в конечном итоге.

Visual Basic

Sub Sum_Unic()
Dim Arr(), i&, ii&, Str$
Dim Unic(), Svod()
Dim oDict:
Set oDict = CreateObject("Scripting.Dictionary")
With Sheets("Данные")
    Arr = Intersect(.UsedRange, .Range("A:F"))
    With oDict
        For i = 2 To UBound(Arr)
        s = Arr(i, 1) & " " & Arr(i, 2) & " " & Arr(i, 6)
            If .exists(s) Then
                .Item(s) = .Item(s) + Arr(i, 4)
            Else
                .Add Key:=s, Item:=Arr(i, 4)
            End If
        Next
        MiKeys = .Keys
        MiItems = .Items
        
        ReDim Unic(.Count, 4)
        For i = 0 To .Count - 1
           Unic(i, 0) = Split(MiKeys(i))(2)  
            Unic(i, 1) = Split(MiKeys(i))(0)  
            Unic(i, 2) = Split(MiKeys(i))(1)  
            Unic(i, 3) = MiItems(i)            
        Next
End With
End With
    Sheets("Вывод (что получается)").Range("A2").Resize(UBound(Unic), 4) = Unic
End Sub

@tyler14 · 26.09.2017, 14:29 **[ТС]**

Прилагаю файл.

@Hugo121 · 27.09.2017, 10:01

1. строки 11, 13, 14 и 15 лишние, без них будет быстрее с тем же результатом.
2. Позиции ключей и итемов не регламентируются, т.е. всё что ниже 20-й строки потенциально ненадёжно.
Ну а подробнее смотреть сейчас некогда...

Добавлено через 8 часов 18 минут
Чуть попаразитировал...
Даты извините не все, только те что есть. Лень с этим возиться.

Visual Basic

Option Explicit
 
Sub Sum_Unic()
    Dim Arr(), i&, ii&, col1 As New Collection, col2 As New Collection, s$
    Dim Unic()
    Dim oDict As Object
 
    Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
    With Sheets("Данные")
        Arr = Intersect(.UsedRange, .Range("A:F"))
        With oDict
            On Error Resume Next
            For i = 2 To UBound(Arr)
                With col2
                    s = Arr(i, 6) & "|" & Arr(i, 2)
                    For ii = 1 To .Count
                        If s < .Item(ii) Then
                            .Add s, s, Before:=ii: Exit For
                        End If
                    Next
                    .Add s, s
                End With
 
                With col1
                    For ii = 1 To .Count
                        If Arr(i, 1) < .Item(ii) Then
                            .Add Arr(i, 1), CStr(Arr(i, 1)), Before:=ii: Exit For
                        End If
                    Next
                    .Add Arr(i, 1), CStr(Arr(i, 1))
                End With
 
                s = Arr(i, 1) & "|" & Arr(i, 6) & "|" & Arr(i, 2)
                .Item(s) = .Item(s) + Arr(i, 4)
            Next
            On Error GoTo 0
 
 
            ReDim Unic(1 To col2.Count + 1, 1 To col1.Count + 2)
 
            For ii = 1 To col1.Count
                Unic(1, ii + 2) = col1(ii)
                For i = 1 To col2.Count
                    s = col1(ii) & "|" & col2(i)
                    Unic(i + 1, 1) = Split(col2(i), "|")(0)
                    Unic(i + 1, 2) = Split(col2(i), "|")(1)
                    Unic(i + 1, ii + 2) = oDict.Item(s)
                Next
            Next
        End With
    End With
 
    With Sheets("Вывод (что получается)").Range("A1")
        .Resize(1, UBound(Unic, 2)).NumberFormat = "mmm-yy"
        .Resize(UBound(Unic), UBound(Unic, 2)) = Unic
    End With
End Sub

Добавлено через 10 часов 53 минуты
Правда в строках 45 и 46 часто делается лишняя работа, можно придумать как её не делать.
Например сперва отдельным циклом заполнить эту "шапку", и затем более на это не отвлекаться.
Ну и строку 47 вероятно лучше написать так:

Visual Basic

1	If oDict.exists(s) then Unic(i + 1, ii + 2) = oDict.Item(s)

@tyler14 · 27.09.2017, 13:04 **[ТС]**

Hugo121, спасибо большое!!!
Буду сейчас изучать

@tyler14 · 05.12.2017, 15:23 **[ТС]**

Hugo121, все-таки без вашей помощи не смогу доделать задуманное.
Во вложении файл, с той формой, к которой в конечном счете нужно привести данные (вкладка "Вывод (как должно быть)").

@Hugo121 · 05.12.2017, 20:56

Скорректировал под конкретный файл:

Visual Basic

Option Explicit
 
 
Sub Sum_Unic2()
    Dim Arr(), i&, ii&, col2 As New Collection, s$
    Dim oDict As Object
 
    Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
    With Sheets("Данные")
        Arr = Intersect(.UsedRange, .Range("A:F"))
        With oDict
            On Error Resume Next
            For i = 2 To UBound(Arr)
                With col2
                    s = Arr(i, 6) & "|" & Arr(i, 2)
                    For ii = 1 To .Count
                        If s < .Item(ii) Then
                            .Add s, s, Before:=ii: Exit For
                        End If
                    Next
                    .Add s, s
                End With
 
                s = Arr(i, 1) & "|" & Arr(i, 6) & "|" & Arr(i, 2)
                .Item(s) = .Item(s) + Arr(i, 4)
            Next
            On Error GoTo 0
 
            Application.ScreenUpdating = False
            With Sheets("Вывод (как должно быть)")
                For ii = 3 To 26
                    For i = 1 To col2.Count
                        s = .Cells(1, ii) & "|" & col2(i)
                        .Cells(i + 2, 1) = Split(col2(i), "|")(0)
                        .Cells(i + 2, 2) = Split(col2(i), "|")(1)
                        If oDict.exists(s) Then .Cells(i + 2, ii + 2) = oDict.Item(s)
                    Next
                Next
            End With
            Application.ScreenUpdating = True
            
        End With
 
    End With
End Sub

Не понял зачем там разбивка по этим рамочкам, но если нужно - то можно делать соответствующий сдвиг доппеременной в цикле For i = 1 To col2.Count

@tyler14 · 06.12.2017, 18:57 **[ТС]**

Hugo121, спасибо большое!!!
Что касается рамочек, задумка была следующая - каждой рамке (области) соответствет только один Тип с его уникальными Видами. Сами рамки (области) располагаются друг под другом с разрывом в 1-3 строки.
Был бы очень признателен, если б подсказали как это реализовать. Пока у меня удалось вы тянуть в каждую рамку только все уникальные Виды сразу (а хотелось бы только те уникальные, что соответствуют своему Типу). Надеюсь не очень запутал))

@Hugo121 · 06.12.2017, 20:08

Тогда почему там в первой рамке разные типы?
Тогда можно в код добавить ещё один словарь типов, где каждому типу собирать коллекцию его видов.
В финале цикл по этому словарю, в нём цикл по каждой коллекции - собираем начало ключа, идём циклом по датам - добавляем в ключ - если в словаре oDict есть значение, кладём в ячейку.
Когда переходим к следующему ключу словаря типов - можно натянуть рамку по данным предыдущего ключа, отступить на пару тройку строк ниже.
Делать геморно, сейчас недосуг. Попробуйте сами - я вроде всё подробно описал.
Пример словаря с коллекциями (но тут в коллекцию собирается всё, без отбора уникальных) (и заодно словарь в словаре):

Visual Basic

Sub PereborFailov() 'коллекция в словаре
    Dim a, i&, t$, Dic As Object
    Dim el, col
    
    a = Range("C3", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1)
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add a(i, 2) & "|" & a(i, 3) & "|" & i
        Next
    End With
    
    For Each el In Dic.keys
        Debug.Print "Открываем файл " & el
        For Each col In Dic.Item(el)
            Debug.Print "Ищем данные " & col
        Next
        Debug.Print "Закрываем файл " & el
    Next
 
End Sub
 
Sub PereborFailov2() ' словарь в словаре
    Dim a, i&, t$, Dic As Object, Dic2 As Object
    Dim el, col
    
    a = Range("C3", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1)
            If Not .exists(t) Then .Add t, CreateObject("Scripting.Dictionary")
            .Item(t).Item(a(i, 2) & "|" & a(i, 3) & "|" & i) = 0&
            
        Next
    End With
    
    For Each el In Dic.keys
        Debug.Print "Открываем файл " & el
        Set Dic2 = Dic.Item(el)
        For Each col In Dic2.keys
            Debug.Print "Ищем данные " & col '& "|" & Dic2.Item(col)
        Next
        Debug.Print "Закрываем файл " & el
    Next
 
End Sub

@tyler14 0 / 0 / 0 Регистрация: 29.06.2017 Сообщений: 9
	27.09.2017, 13:04 [ТС]	4
	Hugo121, спасибо большое!!! Буду сейчас изучать 0

@tyler14 0 / 0 / 0 Регистрация: 29.06.2017 Сообщений: 9
	06.12.2017, 18:57 [ТС]	7
	Hugo121, спасибо большое!!! Что касается рамочек, задумка была следующая - каждой рамке (области) соответствет только один Тип с его уникальными Видами. Сами рамки (области) располагаются друг под другом с разрывом в 1-3 строки. Был бы очень признателен, если б подсказали как это реализовать. Пока у меня удалось вы тянуть в каждую рамку только все уникальные Виды сразу (а хотелось бы только те уникальные, что соответствуют своему Типу). Надеюсь не очень запутал)) 0

Опции темы