求助各位大师

564746423

我B2列是名字，我想把B2列出现4次以上的名字放在E列，并且把该名字在B列的总出现次数统计出来放到F列中，如何实现，求助各位了

盼盼198310

................

kkf5560

1. Option Explicit
   
2. 
   
3. Sub t()
   
4.     Dim dic As Object, d As Object, aData, aRes, i, n, strName
   
5.     Set dic = CreateObject("Scripting.Dictionary")
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     aData = Range("a1").CurrentRegion
   
8.     ReDim aRes(1 To UBound(aData), 1 To 2)
   
9.     For i = 1 To UBound(aData)
   
10.         strName = aData(i, 2)
    
11.         dic(strName) = dic(strName) + 1
    
12.         If dic(strName) > 3 Then
    
13.             If Not d.exists(strName) Then
    
14.                 n = n + 1
    
15.                 d(strName) = n
    
16.                 aRes(n, 1) = strName
    
17.             End If
    
18.             aRes(d(strName), 2) = dic(strName)
    
19.         End If
    
20.     Next i
    
21.     Range("e2").Resize(n, 2) = aRes
    
22. End Sub
    

复制代码

shiruiqiang

tiger1976

Sub lll()

    Dim arr, err
    Dim trr()
    Dim dic As Object
    Dim i, k, m, n As Integer
   
    Set dic = CreateObject("scripting.dictionary")
    i = Cells(Rows.Count, 2).End(xlUp).Row
    arr = Range("b1:b" & i)
    Range("e2:f100000").Clear
   
    For k = 2 To UBound(arr)
        dic.Item(arr(k, 1)) = ""
    Next
    err = dic.Keys
   
    For i = 0 To UBound(err)
    m = 0
        For k = 2 To UBound(arr)
            If err(i) = arr(k, 1) Then
                m = m + 1
            End If
        Next
        If m >= 4 Then
            n = n + 1
            ReDim Preserve trr(1 To 2, 1 To n)
            trr(1, n) = err(i)
            trr(2, n) = m
        End If
    Next
    Range("e2").Resize(UBound(trr, 2), 2) = Application.WorksheetFunction.Transpose(trr)
End Sub

564746423

盼盼198310 发表于 2023-3-29 08:09
................

太厉害了，感激大师

564746423

kkf5560 发表于 2023-3-29 08:15

感激大师

564746423

shiruiqiang 发表于 2023-3-29 08:16

感激大师

tanglf188

参与一下

准提部林

Sub TEST_A1()
Dim Arr, xD, i&, T$, n&
Set xD = CreateObject("Scripting.Dictionary")
Arr = [a1].CurrentRegion
For i = 1 To UBound(Arr)
    T = Arr(i, 2): xD(T) = xD(T) + 1
    If xD(T) = 4 Then n = n + 1: Arr(n, 1) = T: xD(T & "/n") = n
    If xD(T) > 3 Then Arr(xD(T & "/n"), 2) = xD(T)
Next i
[e2:e6000].ClearContents
If n > 0 Then [e2].Resize(n, 2) = Arr
End Sub