Подсчет уникальных в дате

[strannick]

Добрый день, уважаемые форумчане!
Готовлю данные для статистики. Раньше все считалось формулами. Достаточно было извлечь уникальные значения по номерам и датам. Сейчас появилась необходимость подсчета макросом. Во вложении пример. Извлек уникальные номера счетов в столбец E, извлек уникальные даты в столбец F. Теперь надо просчитать количество уникальных номеров счетов в дате и проставить в столбце G. Попытался прописать код:

Sub Счет()
Dim a(), b(), c(), t$, i&, x&, y&

a = [a2].CurrentRegion.Value
b = [e2].CurrentRegion.Value
c = [f2].CurrentRegion.Value
With CreateObject("scripting.dictionary")

For i = 2 To UBound(a)
t = a(i, 1) & "|" & a(i, 2)
Next

For x = 2 To UBound(b)
For y = 2 To UBound(c)
t = b(x, 5) & "|" & c(y, 6)
If .exists(t) Then
t = .Item(t)
Else
t = 0
End If
Next
Next

End With
[g2].CurrentRegion.Value = t

End Sub

Не работает. Поправьте меня, где я напортачил.
Заранее спасибо!

[staniiislav]

а так вам не подойдет?

Sub Ñ÷åò()
Dim a(), i&
a = [A2].CurrentRegion.Value

With CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
         .Item(a(i, 1) & "|" & a(i, 2)) = .Item(a(i, 1) & "|" & a(i, 2)) + 1
    Next i
    If .Count Then [F2].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.Keys)
    If .Count Then [G2].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.items)
End With


End Sub

[strannick]

Сообщение от staniiislav

а так вам не подойдет?

Подойдет. А я тут целую гору нагородил уже. Спасибо! Вот эта строчка не нужна. Проверил, кол-во вхождений в дату соответствует.

    If .Count Then [F2].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.Keys)

Опробую на основных данных. Еще раз спасибо!

А не, не совсем так. В F выгружаются номер счета|дата, а в G кол-во таких вариантов. Не хватает чего-то, отбора по дате. Главное тут дата (столбец F). И если уж в нем отобраны все уникальные даты, то в столбец G - количество вхождений в эти даты. Нужен еще один шажок. Думаю.

[staniiislav]

не совсем пойму чего вы хотите добиться, пробуйте так:

Sub Счет()
Dim a(), i&
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary")
Dim oDict2: Set oDict2 = CreateObject("Scripting.Dictionary")
a = [A2].CurrentRegion.Value

    For i = 2 To UBound(a)
        oDict.Item(a(i, 1)) = oDict.Item(a(i, 1))
        oDict2.Item(a(i, 2)) = oDict2.Item(a(i, 2)) + 1
    Next i
    
    If oDict.Count Then [E2].Resize(oDict.Count).Value = Application.WorksheetFunction.Transpose(oDict.Keys)
    If oDict2.Count Then [F2].Resize(oDict2.Count).Value = Application.WorksheetFunction.Transpose(oDict2.Keys)
    If oDict2.Count Then [G2].Resize(oDict2.Count).Value = Application.WorksheetFunction.Transpose(oDict2.items)

End Sub

[strannick]

Сообщение от staniiislav

не совсем пойму чего вы хотите добиться,

Ага, видно не совсем правильно поставил вопрос. Счетов в конкретной дате с одним номером может быть несколько. Так вот, в результате надо получить количество вхождений уникальных номеров счетов в дату. Например, если за 21.02.2013 были номера 2112, 2112, 2113, то получается, что уникальных 2 штуки - 2112 и 2113. Вот так по каждой дате получить количество вхождение уникальных номеров.

[staniiislav]

Сообщение от strannick

Ага, видно не совсем правильно поставил вопрос. Счетов в конкретной дате с одним номером может быть несколько. Так вот, в результате надо получить количество вхождений уникальных номеров счетов в дату. Например, если за 21.02.2013 были номера 2112, 2112, 2113, то получается, что уникальных 2 штуки - 2112 и 2113. Вот так по каждой дате получить количество вхождение уникальных номеров.

если правильно понял:

Sub Счет()
Dim a(), b(), i&, k, u, n&, n2&
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary")
Dim oDict2: Set oDict2 = CreateObject("Scripting.Dictionary")
Dim oDict3: Set oDict3 = CreateObject("Scripting.Dictionary")
a = [A2].CurrentRegion.Value
    For i = 2 To UBound(a)
        oDict.Item(a(i, 1)) = oDict.Item(a(i, 1))
        oDict2.Item(a(i, 2)) = oDict2.Item(a(i, 2))
        oDict3.Item(a(i, 1) & "|" & a(i, 2)) = oDict3.Item(a(i, 1) & "|" & a(i, 2))
    Next i
    ReDim b(1 To oDict2.Count, 1 To 1)
    For Each k In oDict2.Keys
    n = n + 1
        For Each u In oDict3.Keys
            For i = 2 To UBound(a)
                If a(i, 1) & "|" & a(i, 2) = u Then
                    If a(i, 2) = k Then n2 = n2 + 1: Exit For
                End If
            Next i
        Next
        b(n, 1) = n2
        n2 = 0
    Next
    Range("E2:G" & Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
    If oDict.Count Then [E2].Resize(oDict.Count).Value = Application.WorksheetFunction.Transpose(oDict.Keys)
    If oDict2.Count Then [F2].Resize(oDict2.Count).Value = Application.WorksheetFunction.Transpose(oDict2.Keys)
    [G2].Resize(n).Value = b

End Sub

[strannick]

[QUOTE=staniiislav;1189990]если правильно понял:

Абсолютно правильно! Сейчас потестю на основном файле и отпишусь. Большущее спасибо!

[DiemonStar]

staniiislav,
можно было из вашего же примера сделать намного проще:

Sub Cnt()
Dim a(), i&
a = [A2].CurrentRegion.Value

Set Dates = CreateObject("scripting.dictionary")

With CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
      If Not .Exists(a(i, 1) & "|" & a(i, 2)) Then
        .Item(a(i, 1) & "|" & a(i, 2)) = 1
        Dates.Item(a(i, 2)) = Dates.Item(a(i, 2)) + 1
      Else
        .Item(a(i, 1) & "|" & a(i, 2)) = .Item(a(i, 1) & "|" & a(i, 2)) + 1
      End If
    Next i
End With
If Dates.Count Then [F2].Resize(Dates.Count).Value = Application.WorksheetFunction.Transpose(Dates.Keys)
If Dates.Count Then [G2].Resize(Dates.Count).Value = Application.WorksheetFunction.Transpose(Dates.Items)
End Sub

[strannick]

Ребята, всем огромнющее СПАСИБО! Все варианты рабочие, потестил на основном файле. Последний вариант работает немного быстрее. Есть еще небольшая просьба такого плана - в этом же коде подбивать общую сумму счетов за эту дату по столбцу С, ну и выводить эти суммы в столбец, следующий за количеством счетов в дате? Чтоб уже не задействовать СУММПРОИЗВ.

[nilem]

можно еще со сводной попробовать

Sub ertert()
Dim ptCache As PivotCache
Application.ScreenUpdating = False
With ActiveSheet
    If .PivotTables.Count > 0 Then .PivotTables(1).TableRange2.Clear
End With
Set ptCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, Range("A1").CurrentRegion)
With ActiveSheet.PivotTables.Add(ptCache, Range("I1"))
    .AddDataField .PivotFields("Номер счета"), "Количество счетов по дате", xlCount
    With .PivotFields("Дата")
        .Orientation = xlRowField: .Position = 1
    End With
    With .PivotFields("Номер счета")
        .Orientation = xlRowField: .Position = 2
    End With
    .CompactLayoutRowHeader = "Счета по датам"
    .GrandTotalName = "Всего счетов"
    .TableStyle2 = "PivotStyleLight21"
End With
With Range("I1:J1")
    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True
End With
With Columns(10)
    .HorizontalAlignment = xlCenter: .ColumnWidth = 15.43
End With
Application.ScreenUpdating = True
End Sub