用VBA提取重复的次数并列出来

chbb6666

用VBA提取重复的次数并列出来

ykcbf1100

附件供参考。。。

ykcbf1100

代码以附件为准。

1. Sub ykcbf()   '//2024.1.31
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("表2")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 1)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 1)
    
11.         d(s) = d(s) + 1
    
12.     Next
    
13.     With Sheets("表1")
    
14.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
15.         arr = .[a1].Resize(r, 2)
    
16.         For i = 2 To UBound(arr)
    
17.             s = arr(i, 1)
    
18.             If d.exists(s) Then
    
19.                 If d(s) > 1 Then
    
20.                     arr(i, 2) = d(s)
    
21.                 Else
    
22.                     arr(i, 2) = ""
    
23.                 End If
    
24.             End If
    
25.         Next
    
26.         .[a1].Resize(r, 2) = arr
    
27.     End With
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

chbb6666

ykcbf1100 发表于 2024-1-31 11:17
附件供参考。。。

谢谢老师，但我还需要根据B列的次数选出重复出现2次以上的姓名，写入D列，别如果是示出现也显示0

ykcbf1100

chbb6666 发表于 2024-1-31 11:26
谢谢老师，但我还需要根据B列的次数选出重复出现2次以上的姓名，写入D列，别如果是示出现也显示0

改好了。。。

chbb6666

ykcbf1100 发表于 2024-1-31 11:29
改好了。。。

思路是对的，但我如果张三1次的话，D列选出来的就有空格，要求是去掉空格重新排列

ykcbf1100

chbb6666 发表于 2024-1-31 11:37
思路是对的，但我如果张三1次的话，D列选出来的就有空格，要求是去掉空格重新排列

你求助时可没有这些要求。
你自己玩吧。

szdcp

chbb6666 发表于 2024-1-31 11:37
思路是对的，但我如果张三1次的话，D列选出来的就有空格，要求是去掉空格重新排列

菜鸟笨办法能实际你要的功能，请勿见笑

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("表2").UsedRange
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            d(arr(j, 1)) = d(arr(j, 1)) + 1
        End If
    Next j
    Application.ScreenUpdating = False
    Sheets("表1").Select
    Sheets("表1").UsedRange.Offset(1, 1).ClearContents
    arr = Sheets("表1").UsedRange
    For j = 2 To UBound(arr)
        If d.exists(arr(j, 1)) Then
            arr(j, 2) = d(arr(j, 1))
        Else
            arr(j, 2) = 0
        End If
    Next j
    For Each k In d.keys
        If d(k) = 1 Then d.Remove k
    Next k
    Sheets("表1").[a1].Resize(UBound(arr), 2) = arr
    If d.Count > 0 Then [d2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    Application.ScreenUpdating = True
End Sub

liulang0808

用VBA提取重复的次数并列出来.zip (15.95 KB, 下载次数: 22)

2024-1-31 12:53 上传

点击文件名下载附件

附件内容供参考。。。。