Question

我需要从Sheet1上的A列中提取唯一名称，而Sheet2上只显示每个名称中的一个及其出现的次数。工作表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

加里的学生解决方案绝对更清洁！

从excel中的未知范围大小中提取唯一项目及其计数

3 个答案: