Excel VBA для подсчета и печати различных значений

Question

Я должен посчитать количество различных значений из столбца и распечатать его с другим значением и подсчитать на другом листе. Я работаю с этим фрагментом кода, но по какой-то причине он не возвращает никакого результата. Кто-нибудь может сказать мне, где я скучаю по кусочку!

Dim rngData As Range
Dim rngCell As Range
Dim colWords As Collection
Dim vntWord As Variant
Dim Sh As Worksheet
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet

On Error Resume Next

Set Sh1 = Worksheets("A")
Set Sh2 = Worksheets("B")
Set Sh3 = Worksheets("C")

Sh1.Range("A2:B650000").Delete

Set Sh = Worksheets("A")
Set r = Sh.AutoFilter.Range
r.AutoFilter Field:=24
r.AutoFilter Field:=24, Criteria1:="My Criteria"

Sh1.Range("A2:B650000").Delete

Set colWords = New Collection

Dim lRow1 As Long
lRow1 = <some number>

Set rngData = <desired range>
For Each rngCell In rngData.Cells
    colWords.Add colWords.Count + 1, rngCell.Value
    With Sh1.Cells(1 + colWords(rngCell.Value), 1)
        .Value = rngCell.Value
        .Offset(0, 1) = .Offset(0, 1) + 1
    End With
Next

Выше приведен мой полный код. Мой требуемый результат прост: подсчитать количество вхождений каждой ячейки в столбце и распечатать его на другом листе с количеством вхождений. Спасибо!

Спасибо! Navs.

Answer 1

Это очень легко и практично сделать с помощью словарного объекта.Логика аналогична ответу Китто, но объект словаря намного быстрее, эффективнее, и вы можете вывести массив всех ключей и элементов, которые вы хотите сделать здесь.Я упростил код для генерации списка из столбца А, но вы поймете идею.

Sub UniqueReport()

Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant

varray = Range("A1:A10").Value

'Generate unique list and count
For Each element In varray
    If dict.exists(element) Then
        dict.Item(element) = dict.Item(element) + 1
    Else
        dict.Add element, 1
    End If
Next

'Paste report somewhere
Sheet2.Range("A1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.keys)
Sheet2.Range("B1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.items)

End Sub

Как это работает : вы просто сбрасываете диапазон в массив вариантов для циклабыстро, затем добавьте каждый в словарь.Если он существует, вы просто берете предмет с ключом (начинается с 1) и добавляете его к нему.Затем в конце просто шлепните уникальный список и подсчитайте, где он вам нужен.Обратите внимание, что способ создания объекта для словаря позволяет любому использовать его - нет необходимости добавлять ссылку на ваш код.

Answer 2

Не самый красивый и не самый оптимальный маршрут, но он выполнит свою работу, и я уверен, что вы можете это понять:

Option Explicit

Sub TestCount()

Dim rngCell As Range
Dim arrWords() As String, arrCounts() As Integer
Dim bExists As Boolean
Dim i As Integer, j As Integer

ReDim arrWords(0)

For Each rngCell In ThisWorkbook.Sheets("Sheet1").Range("A1:A20")
    bExists = False

    If rngCell <> "" Then
        For i = 0 To UBound(arrWords)
            If arrWords(i) = rngCell.Value Then
                bExists = True
                arrCounts(i) = arrCounts(i) + 1
            End If
        Next i

        If bExists = False Then
            ReDim Preserve arrWords(j)
            ReDim Preserve arrCounts(j)

            arrWords(j) = rngCell.Value
            arrCounts(j) = 1

            j = j + 1
        End If
    End If
Next

For i = LBound(arrWords) To UBound(arrWords)
    Debug.Print arrWords(i) & ", " & arrCounts(i)
Next i

End Sub

Это будет проходить через A1: A20 на «Лист1». Если ячейка не пуста, она проверит, существует ли слово в массиве. Если нет, то он добавляет его в массив со счетчиком 1. Если он существует, он просто добавляет 1 к счетчику. Я надеюсь, что это соответствует вашим потребностям.

Кроме того, просто кое-что, о чем следует помнить после просмотра вашего кода: вы практически НИКОГДА не должны использовать On Error Resume Next.