Code macro thay cho hàm đếm ký tự

[chinghia125]

Xin chào các anh chị em .
Mình cần hổ trợ code thay cho hàm đếm ký tự , như file đính kèm . Nhờ code đơn giản nhất .

 

[leonguyenz]

Xin chào các anh chị em .
Mình cần hổ trợ code thay cho hàm đếm ký tự , như file đính kèm . Nhờ code đơn giản nhất .

Nếu dùng hàm, sử dụng công thức sau:

=H1&COUNTIF($H$1:H1,H1)

 

[chinghia125]

Nếu dùng hàm, sử dụng công thức sau:

=H1&COUNTIF($H$1:H1,H1)

Cám ơn anh , nhưng em cần code macro , để chèn vào macro của mình .

 

[leonguyenz]

Cám ơn anh , nhưng em cần code macro , để chèn vào macro của mình .

Tham khảo code sau:

Sub Gpe_C()
Dim Dic As Object
    Dim iR As Long, Tmp As String, sArr, rArr
    Sheet1.Range("J1").Resize(1000).ClearContents
    sArr = Range(Sheet1.[H1], Sheet1.[H65535].End(3)).Value
    ReDim rArr(1 To UBound(sArr, 1), 1 To 1)
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For iR = 1 To UBound(sArr, 1)
            Tmp = sArr(iR, 1)
            If Not .Exists(Tmp) Then
                .Add Tmp, 1
                rArr(iR, 1) = Tmp & 1
            Else
                .Item(Tmp) = .Item(Tmp) + 1
            End If
            rArr(iR, 1) = Tmp & .Item(Tmp)
        Next iR
    End With
    If iR Then Sheet1.Range("J1").Resize(iR - 1) = rArr
    Set Dic = Nothing
End Sub

 

[chinghia125]

Tham khảo code sau:

Sub Gpe_C()
Dim Dic As Object
    Dim iR As Long, Tmp As String, sArr, rArr
    Sheet1.Range("J1").Resize(1000).ClearContents
    sArr = Range(Sheet1.[H1], Sheet1.[H65535].End(3)).Value
    ReDim rArr(1 To UBound(sArr, 1), 1 To 1)
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For iR = 1 To UBound(sArr, 1)
            Tmp = sArr(iR, 1)
            If Not .Exists(Tmp) Then
                .Add Tmp, 1
                rArr(iR, 1) = Tmp & 1
            Else
                .Item(Tmp) = .Item(Tmp) + 1
            End If
            rArr(iR, 1) = Tmp & .Item(Tmp)
        Next iR
    End With
    If iR Then Sheet1.Range("J1").Resize(iR - 1) = rArr
    Set Dic = Nothing
End Sub

Cám ơn leonguyenz nhiều , code chạy tốt .