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

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

цикла

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.

Answer 2

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

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) и добавляет его к нему. Затем в конце просто удалите уникальный список и подсчеты, где вам это нужно. Обратите внимание, что способ создания объекта для словаря позволяет кому-либо его использовать - нет необходимости добавлять ссылку на ваш код.