添序号

ddz79101

老师！有1列，我希望若上下有单元格一致，则在字符的尾部添加序号。谢谢！

kyxfyzg

1. Sub shishi()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. arr = Range("f1", Cells(Rows.Count, 6).End(xlUp))
   
4. For i = 1 To UBound(arr)
   
5.     If d.Exists(arr(i, 1)) Then
   
6.         d(arr(i, 1)) = d(arr(i, 1)) + 1
   
7.     Else
   
8.         d(arr(i, 1)) = 1
   
9.     End If
   
10. Next i
    
11. For i = 1 To UBound(arr)
    
12.     If d(arr(i, 1)) > 1 Then
    
13.         n = n + 1
    
14.         If n < d(arr(i, 1)) Then
    
15.             arr(i, 1) = arr(i, 1) & n
    
16.         Else
    
17.             arr(i, 1) = arr(i, 1) & n
    
18.             n = 0
    
19.         End If
    
20.     End If
    
21. Next i
    
22. Range("f1").Resize(UBound(arr), 1) = arr
    
23. End Sub
    

复制代码

cidanji

清风竹-

…………………………………………

ynzsvt

1. Sub 重复添加序号()
   
2. Dim Arr, i, j, Dic As Object, k&
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. j = 8'处理的列号，自己更改。
   
5. Arr = Range(Cells(1, j), Cells(Rows.Count, j).End(xlUp))
   
6. For i = 2 To UBound(Arr)
   
7.   If Arr(i, 1) <> "" Then
   
8.    If Not Dic.Exists(Arr(i, 1)) Then
   
9.     Dic(Arr(i, 1)) = -i
   
10.    Else
    
11.     If Dic(Arr(i, 1)) < 0 Then
    
12.      k = -Dic(Arr(i, 1)): Arr(k, 1) = Arr(k, 1) & 1
    
13.      Dic(Arr(i, 1)) = 2: Arr(i, 1) = Arr(i, 1) & 2
    
14.     Else
    
15.      Dic(Arr(i, 1)) = Dic(Arr(i, 1)) + 1: Arr(i, 1) = Arr(i, 1) & Dic(Arr(i, 1))
    
16.     End If
    
17.    End If
    
18.   End If
    
19. Next
    
20. 
    
21. Cells(1, j).Resize(UBound(Arr)) = Arr
    
22. Set Dic = Nothing
    
23. End Sub

复制代码

longwin

Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 6)) = d(arr(i, 6)) + 1
    Next
    For Each m In d.keys
        If d(m) > 1 Then
            cs = 1
            For i = 2 To UBound(arr)
                If arr(i, 6) = m Then
                    arr(i, 6) = arr(i, 6) & cs
                    cs = cs + 1
                End If
            Next
        End If
    Next
[L1].Resize(UBound(arr), UBound(arr, 2)) = arr
Set d = Nothing
End Sub

笨鸟飞不高

换一个写法


Sub AwTest2()
    Dim i&, k&, Xm$, Arr, Brr
    Arr = Range("A1:G" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
    Brr = Arr
    For i = 2 To UBound(Arr) - 1
        If Arr(i, 6) = Arr(i + 1, 6) Or Arr(i, 6) = Arr(i - 1, 6) Then
            If Arr(i, 6) <> Xm Then Xm = Arr(i, 6): k = 0
            k = k + 1
            Brr(i, 6) = Brr(i, 6) & k
        Else
            k = 0
        End If
    Next
    Range("T1").Resize(UBound(Brr) - 1, UBound(Brr, 2)) = Brr
End Sub

ddz79101

kyxfyzg 发表于 2024-8-15 09:34

谢谢老师！运行成功！

ddz79101

cidanji 发表于 2024-8-15 09:38

谢谢老师！运行成功！

ddz79101

ynzsvt 发表于 2024-8-15 09:52

谢谢老师！运行成功！