添序号

ddz79101

longwin 发表于 2024-8-15 09:56
Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion

谢谢老师！运行成功！

ddz79101

清风竹- 发表于 2024-8-15 09:51
…………………………………………

谢谢老师！运行成功！

limonet

关键字：filter

limonet

Sub limonet()
    Dim Arr As Variant, Brr As Variant, i%, Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Arr = Range("A1:G20")
    Brr = Application.Transpose(Range("F1:F20"))
    For i = 1 To UBound(Arr)
        If UBound(Filter(Brr, Arr(i, 6))) > 0 Then
            If Dic.exists(Arr(i, 6)) Then
                Dic(Arr(i, 6)) = Dic(Arr(i, 6)) + 1
            Else
                Dic(Arr(i, 6)) = 1
            End If
            Arr(i, 6) = Arr(i, 6) & Dic(Arr(i, 6))
        End If
    Next i
    Range("Q1").Resize(i - 1, 7) = Arr
End Sub

沈默00

=IF(COUNTIF(F:F,F2)>1,F2&COUNTIF($F$2:$F2,$F2),F2)

ddz79101

笨鸟飞不高 发表于 2024-8-15 10:33

谢谢老师！运行成功！抱歉！花后补

ddz79101

limonet 发表于 2024-8-15 10:46
关键字：filter

谢谢老师！运行成功！抱歉！花后补！

ddz79101

沈默00 发表于 2024-8-15 10:56
=IF(COUNTIF(F:F,F2)>1,F2&COUNTIF($F$2:$F2,$F2),F2)

谢谢老师!公式正确！花后补

sunya_0529

WPS里的JSA练习一下，应该还有更简洁的写法，暂时想不出来了——

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br(), i&, j&, n&, p&, r&
   
    ar = [A1].CurrentRegion.Value: p = 2
   
    For i = 2 To UBound(ar)
        If i = UBound(ar) Then
             r = r + 1
             ReDim Preserve br(1 To 2, 1 To r)
             br(1, r) = p: br(2, r) = i
        Else
            If ar(i + 1, 6) <> ar(p, 6) Then
                r = r + 1
                ReDim Preserve br(1 To 2, 1 To r)
                br(1, r) = p: br(2, r) = i
                p = i + 1
            End If
        End If
    Next i
    For j = 1 To UBound(br, 2)
        If br(2, j) - br(1, j) > 0 Then
            n = 0
            For i = br(1, j) To br(2, j)
                n = n + 1
                ar(i, 6) = ar(i, 6) & n
            Next i
        End If
    Next j
   
    [I1].Resize(UBound(ar), UBound(ar, 2)) = ar
    Beep
End Sub