Excel VBA 计算和打印不同的值

声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow 原文地址: http://stackoverflow.com/questions/9663200/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me): StackOverFlow

提示:将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间:2020-09-11 15:30:04  来源:igfitidea点击:

Excel VBA to count and print distinct values

excelvbaexcel-vba

提问by user1087661

I have to count number of distinct values from a column and print it with the distinct value and count in another sheet. I am working with this piece of code, but for some reason, it is not returning any result. Could anyone tell me where I am missing the piece!

我必须计算一列中不同值的数量,并用不同的值打印它并在另一张纸中计数。我正在处理这段代码,但由于某种原因,它没有返回任何结果。谁能告诉我我在哪里错过了这件作品!

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

Above is my full code.. My required outcome is simple, count number of occurrences of each cell in a column, and print it in another sheet with the count of occurrences. Thanks!

以上是我的完整代码..我需要的结果很简单,计算列中每个单元格的出现次数,然后将其打印在另一张纸上并记录出现次数。谢谢!

Thanks! Navs.

谢谢!导航。

回答by aevanko

This is extreamlly easy and practical to do using a dictionary object. The logic is similar to Kittoes answer, but the dictionary object is much faster, effecient, and you can output an array of all keys and items, which you want to do here. I have simplified the code to generating a list from column A, but you will get the idea.

使用字典对象做到这一点非常容易和实用。逻辑类似于 Kittoes answer,但字典对象更快、更有效,并且您可以输出所有键和项目的数组,您想在这里做。我已经简化了从 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

How it works: You just dump the range into a variant array to loop through quickly, then add each to the dictionary. If it exists, you just take the item that goes with they key (starts at 1) and add one to it. Then at the end just slap the unique list and the counts wherever you need them. Please note that the way I create an object for the dictionary allows anyone to use it - there is no need to add a reference to your code.

工作原理:您只需将范围转储到一个变体数组中即可快速循环,然后将每个添加到字典中。如果它存在,您只需获取与它们键对应的项目(从 1 开始)并添加一个。然后最后只需将唯一列表和计数放在您需要的任何地方。请注意,我为字典创建对象的方式允许任何人使用它 - 无需添加对代码的引用。

回答by Kittoes0124

Not the prettiest or most optimum route but it'll get the job done and I'm pretty sure you can understand it:

不是最漂亮或最优化的路线,但它可以完成工作,我很确定你能理解它:

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

This will loop through A1:A20 on "Sheet1". If the cell is not blank it will check to see if the word exists in the array. If not then it adds it to the array with a count of 1. If it does exist then it simply adds 1 to the count. I hope this suits your needs.

这将遍历“Sheet1”上的 A1:A20。如果单元格不为空,它将检查该单词是否存在于数组中。如果不是,那么它将它添加到数组中,计数为 1。如果它确实存在,那么它只是将 1 添加到计数中。我希望这适合您的需求。

Also, just something to keep in mind after glancing at your code: you should virtually NEVER use On Error Resume Next.

此外,在浏览您的代码后要记住的一点是:您几乎永远不应该使用On Error Resume Next.