从excel中的未知范围大小拉独特的项目和他们的计数

我需要从Sheet1和Sheet2上的列A中取出唯一名称，只显示每个名称的一个名称和次数。 工作表1上的名称每天都在变化，所以我不能在其中编写任何代码。

Sheet1: A Joe Joe Paul Steve Steve Steve Sheet2: AB Joe 2 Paul 1 Steve 3 

代码我到目前为止：

 Sub testing() Dim data As Variant, temp As Variant Dim obj As Object Dim i As Long Set obj = CreateObject("scripting.dictionary") data = Selection For i = 1 To UBound(data) obj(data(i, 1) & "") = "" Next temp = obj.keys Selection.ClearContents Selection(1, 1).Resize(obj.count, 1) = Application.Transpose(temp) End Sub 

但是，这本身就是一个错误。

这是给我：

 Joe Joe Paul Steve 

Answer 1

考虑使用.RemoveDuplicates ：

 Sub CountUniques() Dim r1 As Range, r2 As Range, r As Range Dim wf As WorksheetFunction Set wf = Application.WorksheetFunction Set r1 = Sheets("Sheet1").Columns(1).Cells Set r2 = Sheets("Sheet2").Range("A1") r1.Copy r2 r2.EntireColumn.RemoveDuplicates Columns:=1, Header:=xlNo For Each r In r2.EntireColumn.Cells v = r.Value If v = "" Then Exit Sub r.Offset(0, 1).Value = wf.CountIf(r1, v) Next r End Sub 

Answer 2

我个人不会用字典，我会做这样的事情 –

 Sub countem() Dim origin As Worksheet Set origin = Sheets("Sheet1") Dim destination As Worksheet Set destination = Sheets("Sheet2") Dim x As Integer x = origin.Cells(Rows.Count, "A").End(xlUp).Row Dim y As Integer y = 1 Dim strName As String Dim rngSearch As Range For i = 1 To x strName = origin.Cells(i, 1).Value Set rngSearch = destination.Range("A:A").Find(strName, , xlValues, xlWhole) If Not rngSearch Is Nothing Then rngSearch.Offset(, 1) = rngSearch.Offset(, 1) + 1 Else: destination.Cells(y, 1) = strName destination.Cells(y, 2) = 1 y = y + 1 End If Next End Sub 

只要运行在目的地search它的来源，如果发现count ++，否则添加它。

Answer 3

一个更详细的答案，如果你坚持使用字典对象，或者如果你有更多的数据处理。

 ' Create Reference to Microsoft Scripting Runtime ' In VBE -> Tools -> References -> Microsoft Scripting Runtime Option Explicit Public Sub UniqueItems() Dim rngInput As Range, rngOutput As Range Dim vUniqueList As Variant Set rngInput = ThisWorkbook.Worksheets(1).Range("A:A") Set rngOutput = ThisWorkbook.Worksheets(2).Range("A:B") vUniqueList = GetUniqueItems(rngInput) rngOutput.ClearContents rngOutput.Resize(UBound(vUniqueList, 1), UBound(vUniqueList, 2)).Value = vUniqueList End Sub Private Function GetUniqueItems(vList As Variant) As Variant Dim sKey As String Dim vItem As Variant Dim oDict As Dictionary If IsObject(vList) Then vList = vList.Value Set oDict = New Dictionary For Each vItem In vList sKey = Trim$(vItem) If sKey = vbNullString Then Exit For AddToCountDict oDict, sKey Next vItem GetUniqueItems = GetDictData(oDict) End Function Private Sub AddToCountDict(oDict As Dictionary, sKey As String) Dim iCount As Integer If oDict.Exists(sKey) Then iCount = CInt(oDict.Item(sKey)) oDict.Remove (sKey) End If oDict.Add sKey, iCount + 1 End Sub Private Function GetDictData(oDict As Dictionary) As Variant Dim i As Integer Dim vData As Variant If oDict.Count > 0 Then ReDim vData(1 To oDict.Count, 1 To 2) For i = 1 To oDict.Count vData(i, 1) = oDict.Keys(i - 1) vData(i, 2) = oDict.Items(i - 1) Next i Else 'return empty array on fail ReDim vData(1 To 1, 1 To 2) End If GetDictData = vData End Function 

加里的学生解决scheme绝对清洁！