有没有办法可以下拉重复几次以上数据

小輝輝□

unique只能列出唯一值
contif因为数据很大的运行很慢
有没有一键下拉只要重复1次以上或者可以变量的A：AA列的所有重复
比如数据A 重复了3次 B重复了2次 C重复了0次 则辅助列得到第一行A 第二行B

quqiyuan

上传个附件吧！

小輝輝□

Sub FilterDuplicatesWithCount()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim rngData As Range
    Dim dictDuplicates As Object
    Dim duplicateValue As Variant
    Dim newRow As Long
   
    ' 设置源工作表和新工作表
    Set wsSource = ThisWorkbook.Worksheets("Sheet1") ' 替换为实际的源工作表名称
    Set wsNew = ThisWorkbook.Worksheets.Add
   
    ' 在新工作表中创建标题行
    wsNew.Range("A1").Value = "Duplicate Data"
    wsNew.Range("B1").Value = "Count"
   
    ' 获取源数据范围
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set rngData = wsSource.Range("A1:AA" & lastRow)
   
    ' 使用字典对象存储重复数据和其出现次数
    Set dictDuplicates = CreateObject("Scripting.Dictionary")
   
    ' 循环检查每个单元格，记录重复数据和其出现次数
    For Each cell In rngData
        If Application.WorksheetFunction.CountIf(rngData, cell.Value) >= 2 Then
            If Not dictDuplicates.Exists(cell.Value) Then
                dictDuplicates.Add cell.Value, 1
            Else
                dictDuplicates(cell.Value) = dictDuplicates(cell.Value) + 1
            End If
        End If
    Next cell
   
    ' 将重复数据和出现次数写入新表
    newRow = 2
    For Each duplicateValue In dictDuplicates.Keys
        wsNew.Cells(newRow, 1).Value = duplicateValue
        wsNew.Cells(newRow, 2).Value = dictDuplicates(duplicateValue)
        newRow = newRow + 1
    Next duplicateValue
   
    ' 自动调整新表的列宽
    wsNew.Columns.AutoFit
   
    MsgBox "重复数据和对应出现次数已统计并复制到新表。", vbInformation
End Sub

这是chatcpt给出的方案 有优化速度的空间吗