Visual Basic for Applications（VBA）计算唯一的单元格

我试图使一个Visual Basicmacros来计算行中的唯一项目，而不做复制和粘贴和数据删除重复项。

出于某种原因，我的语法有问题。 当我运行脚本时，它输出的行数。

这是我第一次使用Visual Basic for Applications（VBA）进行编程。

Private Sub FrequencyCount_Click() Dim rng As Range Dim outcell As Range Dim outnum As Integer Dim MyArray() As Variant Dim ArrayLength As Integer Dim unique As Boolean Dim i outnum = 0 ArrayLength = 1 unique = False Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8) Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8) For Each B In rng.Rows If outnum = 0 Then ReDim MyArray(1) MyArray(ArrayLength) = B.Value outnum = outnum + 1 ArrayLength = ArrayLength + 1 Else i = 0 unique = True Do Until i < ArrayLength If MyArray(i) = B.Value Then unique = False End If i = i + 1 Loop MsgBox unique If unique = True Then ReDim Preserve MyArray(0 To ArrayLength + 1) MyArray(ArrayLength) = B.Value ArrayLength = ArrayLength + 1 outnum = outnum + 1 End If End If Next End outcell.Value = outnum End Sub 

Answer 1

问题是你正在设置i = 0然后说

 Do until i < arraylength` 

那么如果我= 0那么它总是会less于arraylength，这可能应该是

 Do until i > arraylength 

希望这可以帮助 ：）

Answer 2

ReDim数组在循环中通常被认为是不好的做法，不推荐使用。 如果你search互联网，那么像这样的讨论会出现ReDim in Loop

您可以使用内置function来获取所需的位置。 示例代码应该为你工作。

  Sub FrequencyCount_Click() Dim rng As Range Dim outcell As Range Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8) Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8) rng.Copy outcell.Cells(1, 1) outcell.Resize(rng.Cells.Count, 1).RemoveDuplicates 1, xlNo End Sub 

Answer 3

正如@RyanWildry所build议的，你可以使用Dictionary对象来实现。

调用过程的代码还将定义包含重复项和范围的范围，以将唯一值粘贴到：

 Sub Test() 'This will take values in the first range and paste the uniques starting at the second range cell. 'NB: Search for With...End With. With ThisWorkbook.Worksheets("Sheet1") FrequencyCount .Range("B2:B48"), .Range("D2") End With End Sub 

然后，这段代码将把这些值放入一个字典中，这个字典也会删除任何重复的内容，然后使用一些技术将其粘贴回行或列中。
我已经添加了很多评论，这个链接可能有助于进一步阅读Dictionary对象： https ： //excelmacromastery.com/vba-dictionary/

 Public Sub FrequencyCount(SourceRange As Range, TargetRange As Range) Dim oDict As Object Dim rCell As Range Dim vKey As Variant Dim vArr As Variant Dim x As Long Set oDict = CreateObject("Scripting.Dictionary") oDict.comparemode = vbTextCompare 'Non-case sensitive. Use vbBinaryCompare to make case sensitive. 'Go through each cell in the source range and copy the value to the dictionary. For Each rCell In SourceRange 'Change the value in the dictionary referenced by key value. 'If key value doesn't exist create it. oDict(rCell.Value) = rCell.Value Next rCell 'Paste in rows. x = 1 ReDim vArr(1 To oDict.Count) For Each vKey In oDict.Keys vArr(x) = oDict(vKey) x = x + 1 Next vKey TargetRange.Resize(UBound(vArr)) = WorksheetFunction.Transpose(vArr) 'Paste in columns. TargetRange.Resize(1, UBound(Application.Transpose(oDict.Keys))) = oDict.Keys End Sub 

Answer 4

这是一个更紧凑的解决scheme，我从其他解决scheme拼凑在一起。

 Sub UniqueCountinSelection() Dim outcell As Range Dim itms As Object, c As Range, k, tmp As String Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8) Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8) Set itms = CreateObject("scripting.dictionary") For Each c In rng tmp = Trim(c.Value) 'removes leading and trailing spaces If Len(tmp) > 0 Then itms(tmp) = itms(tmp) + 1 Next c outcell.Value = UBound(itms.Keys) + 1 End Sub