從excel中的未知范圍大小中提取獨特的項目及其計數

Question

我需要從 Sheet1 和 Sheet2 上的 A 列中提取唯一名稱，只顯示每個名稱中的一個及其出現的次數。 Sheet 1 上的名稱每天都在變化，因此我無法對其進行硬編碼。

Sheet1:
A
Joe    
Joe
Paul
Steve 
Steve
Steve

Sheet2:
A      B 
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

只需通過原點在目的地搜索它，如果找到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

加里的學生解決方案絕對更干凈！