Конфиф на листе с программой замораживания строк 700к

Question

В настоящее время у меня есть два списка.Список «Grantors» в столбце A и тот же список с дубликатами, удаленными в столбце B. Я пытаюсь подсчитать, сколько раз данный Grantor находится в столбце A, используя countif, однако мой список в столбце A превышает 700 тыс. Строк,Я использую 64-битную Excel, но каждый раз, когда я запускаю код, чтобы сделать это Excel зависает и падает.

Есть ли способ сделать это в Excel, или мне нужно использовать другой подход, например, использование сводной таблицы или создание таблицв доступе?

Я написал несколько подпрограмм, но это последнее, полученное из другого поста на этом форуме.

Sub Countif()

  Dim lastrow As Long
  Dim rRange As Range
  Dim B As Long '< dummy variable to represent column B

  B = 2

  With Application
    .ScreenUpdating = False 'speed up processing by turning off screen updating
    .DisplayAlerts = False
  End With

  'set up a range to have formulas applied
  With Sheets(2)
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rRange = .Range(.Cells(2, B), .Cells(lastrow, B))
  End With

  'apply the formula to the range
  rRange.Formula = "=COUNTIF($A$2:$A$777363,C2)"
  'write back just the value to the range
  rRange.Value = rRange.Value

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With

End Sub

Answer 1

... или, может быть, это.

_{Внимание! Это приводит к перезаписи дедуплицированных значений в столбце A целевого рабочего листа.}

Option Explicit

Sub countUnique()
    Dim arr As Variant, i As Long, dict As Object

    Debug.Print Timer

    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = vbTextCompare

    With Worksheets("sheet2")
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
    End With

    For i = LBound(arr, 1) To UBound(arr, 1)
        dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + 1
    Next i

    With Worksheets("sheet3")
        .Cells(2, "A").Resize(dict.Count, 1) = bigTranspose(dict.keys)
        .Cells(2, "B").Resize(dict.Count, 1) = bigTranspose(dict.items)
    End With

    Debug.Print Timer

End Sub

Function bigTranspose(arr1 As Variant)
    Dim t As Long
    ReDim arr2(LBound(arr1) To UBound(arr1), 1 To 1)

    For t = LBound(arr1) To UBound(arr1)
        arr2(t, 1) = arr1(t)
    Next t
    bigTranspose = arr2
End Function

42,64 секунды для оригиналов 700К и уникальных 327К на планшете Surface Pro.Это можно улучшить, отключив расчет и включив события.Обновление экрана действительно не должно быть проблемой.

Answer 2

Примерно так:

Sub Countif()

    Dim allVals, uniqueVals, i As Long, dict, v, dOut(), r As Long

     ''creating dummy data
'    With Sheet2.Range("A2:A700000")
'        .Formula = "=""VAL_"" & round(RAND()*340000,0)"
'        .Value = .Value
'    End With
'

    'get the raw data and unique values
    With Sheet2
        allVals = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
        uniqueVals = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    End With
    ReDim dOut(1 To UBound(uniqueVals, 1), 1 To 1) 'for counts...

    Set dict = CreateObject("scripting.dictionary")
    'map unique value to index
    For i = 1 To UBound(uniqueVals, 1)
        v = uniqueVals(i, 1)
        If Len(v) > 0 Then dict(v) = i
    Next i


    'loop over the main list and count each unique value in colB
    For i = 1 To UBound(allVals, 1)
        v = allVals(i, 1)
        If Len(v) > 0 Then
            If dict.exists(v) Then
                r = dict(v)
                dOut(r, 1) = dOut(r, 1) + 1
            End If
        End If
    Next i

    'output the counts
    Sheet2.Range("C2").Resize(UBound(dOut, 1), 1).Value = dOut

End Sub

Работает за ~ 30 секунд со значениями 700k в A и уникальными 300k в B