Cần giúp viết Code thêm ký tự 01, 02, 03,... vào bên phải những ô trùng nhau (2 người xem)

hung2412 · 18/12/14

Xin chào các bạn GPE!
Nhờ các bạn giúp đỡ cho tôi vấn đề này với, cụ thể như sau:
Dọc theo cột B có những ô trùng nhau => Có Code nào thêm ký tự 01, 02, 03,... vào bên phải những ô trùng nhau (Thêm ký tự 01, 02, 03,... trực tiếp vào bên phải tại những ô trùng nhau)?
Ví dụ: Ô B13 và ô B15 có ký tự trùng nhau là "PTNN38" => Thêm ký tự 01, 02 vào bên phải của ô B13 và ô B15 => Ô B13 có ký tự mới là "PTNN3801", ô B15 có ký tự mới là "PTNN3802".
Mong các bạn GPE chỉ giáo!
Trân trọng cảm ơn!
P/s: Có 01 File đính kèm.

Hau151978 · 18/12/14

Công thức
=B3 & IF(COUNTIF($B$3:$B$112,B3)>1,TEXT(COUNTIF($B$3:B3,B3),"0#"),"")

sealand · 18/12/14

Cái này dùng công thức rẹt 1 cái chứ dùng Code nó mệt quá.

hung2412 · 18/12/14

sealand đã viết:
Cái này dùng công thức rẹt 1 cái chứ dùng Code nó mệt quá.

Dạ, tôi muốn dùng Code để chèn trực tiếp tại ô đó luôn (Tất nhiên là đã thêm 01, 02, 03,...) ạ.

hung2412 · 18/12/14

Hau151978 đã viết:
Công thức
=B3 & IF(COUNTIF($B$3:$B$112,B3)>1,TEXT(COUNTIF($B$3:B3,B3),"0#"),"")

Cảm ơn bạn, tôi muốn dùng Code để chèn trực tiếp tại ô cần thêm ký tự 01, 02, 03,... luôn.

Hau151978 · 18/12/14

hung2412 đã viết:
Cảm ơn bạn, tôi muốn dùng Code để chèn trực tiếp tại ô cần thêm ký tự 01, 02, 03,... luôn.

Mã:

Sub abc()
    Dim a(), b(), i&, j&, k&, n&
    n = Range("B" & Columns(2).Rows.Count).End(xlUp).Row
    ReDim a(1 To n - 2, 1 To 1)
    ReDim b(1 To n - 2, 1 To 1)
    a = Range("B3:B" & n).Value
    For i = 1 To n - 2
        For j = 1 To n - 2
            If a(i, 1) = a(j, 1) Then
                k = k + 1
                If j <= i Then b(i, 1) = b(i, 1) + 1
            End If
        Next
        If k > 1 Then
            b(i, 1) = a(i, 1) & Format(b(i, 1), "0#")
        Else
            b(i, 1) = a(i, 1)
        End If
    Next
    Range("C3:C" & n) = b
 End Sub

hung2412 · 18/12/14

Hau151978 đã viết:

Mã:

Sub abc()
    Dim a(), b(), i&, j&, k&, n&
    n = Range("B" & Columns(2).Rows.Count).End(xlUp).Row
    ReDim a(1 To n - 2, 1 To 1)
    ReDim b(1 To n - 2, 1 To 1)
    a = Range("B3:B" & n).Value
    For i = 1 To n - 2
        For j = 1 To n - 2
            If a(i, 1) = a(j, 1) Then
                k = k + 1
                If j <= i Then b(i, 1) = b(i, 1) + 1
            End If
        Next
        If k > 1 Then
            b(i, 1) = a(i, 1) & Format(b(i, 1), "0#")
        Else
            b(i, 1) = a(i, 1)
        End If
    Next
    Range("C3:C" & n) = b
 End Sub

Cảm ơn bạn, sao hầu như ô nào cũng thêm 01 ở đằng sau nhỉ? (Mặc dù ô đó không trùng với ô nào khác cả)

Hau151978 · 18/12/14

hung2412 đã viết:
Cảm ơn bạn, sao hầu như ô nào cũng thêm 01 ở đằng sau nhỉ? (Mặc dù ô đó không trùng với ô nào khác cả)

Mình sửa code cũ đang dùng mảng, bây giờ thay bằng biến k nên chương trình chạy sai, bạn thêm k=0 vào sau lệnh For i=....

Mã:

Sub abc()
    Dim a(), b(), i&, j&, k&, n&
    n = Range("B" & Columns(2).Rows.Count).End(xlUp).Row
    ReDim a(1 To n - 2, 1 To 1)
    ReDim b(1 To n - 2, 1 To 1)
    a = Range("B3:B" & n).Value
    For i = 1 To n - 2
        k = 0
        For j = 1 To n - 2
            If a(i, 1) = a(j, 1) Then
                k = k + 1
                If j <= i Then b(i, 1) = b(i, 1) + 1
            End If
        Next
        If k > 1 Then
            b(i, 1) = a(i, 1) & Format(b(i, 1), "0#")
        Else
            b(i, 1) = a(i, 1)
        End If
    Next
    Range("C3:C" & n) = b
 End Sub

hung2412 · 18/12/14

Hau151978 đã viết:

Mình sửa code cũ đang dùng mảng, bây giờ thay bằng biến k nên chương trình chạy sai, bạn thêm k=0 vào sau lệnh For i=....

Mã:

Sub abc()
    Dim a(), b(), i&, j&, k&, n&
    n = Range("B" & Columns(2).Rows.Count).End(xlUp).Row
    ReDim a(1 To n - 2, 1 To 1)
    ReDim b(1 To n - 2, 1 To 1)
    a = Range("B3:B" & n).Value
    For i = 1 To n - 2
        k = 0
        For j = 1 To n - 2
            If a(i, 1) = a(j, 1) Then
                k = k + 1
                If j <= i Then b(i, 1) = b(i, 1) + 1
            End If
        Next
        If k > 1 Then
            b(i, 1) = a(i, 1) & Format(b(i, 1), "0#")
        Else
            b(i, 1) = a(i, 1)
        End If
    Next
    Range("C3:C" & n) = b
 End Sub

Cảm ơn bạn. Nếu thay dòng này:

PHP:

Range("C3:C" & n) = b

bằng dòng này:

PHP:

Range("B3:B" & n) = b

=> Chèn trực tiếp tại cột B luôn.

SA_DQ · 19/12/14

Nếu dữ liệu của bạn được fép sắp xếp lại thì mình tin rằng macro lúc đó làm việc sẽ nhanh chóng hơn nhiều.

VetMini · 19/12/14

HYen17 đã viết:
Nếu dữ liệu của bạn được fép sắp xếp lại thì mình tin rằng macro lúc đó làm việc sẽ nhanh chóng hơn nhiều.

Không cần phải sắp xếp. Bài này bạn có thể dùng Dictionary rất hiệu quả.

Tuy nhiên, vì có chuyện nếu không có trùng lặp thì để yên (không thêm 01) cho nên lúc đếm số trong Dictionary cần một mẹo nhỏ.

Quang_Hải · 19/12/14

Bài này muốn gọn thì không hiệu quả, hiệu quả thì lại hơi lằng nhằng
Thử món Dic này

PHP:

Sub abc()
Dim Arr(), i&, Tem, dk$
Arr = Range("B3", [B65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Arr)
      dk = Arr(i, 1)
      If Not .exists(dk) Then
         .Add dk, i & "#" & 1
      Else
         If Not IsNumeric(.Item(dk)) Then
            Tem = Split(.Item(dk), "#")
            Arr(Tem(0), 1) = Arr(Tem(0), 1) & "*01"
            .Item(dk) = 2
            Arr(i, 1) = Arr(i, 1) & "*02"
         Else
            .Item(dk) = .Item(dk) + 1
            Arr(i, 1) = dk & "*" & Format(.Item(dk), "00")
         End If
      End If
   Next
End With
[E3].Resize(i - 1) = Arr
End Sub

VetMini · 19/12/14

quanghai1969 đã viết:

Bài này muốn gọn thì không hiệu quả, hiệu quả thì lại hơi lằng nhằng
Thử món Dic này

PHP:

Sub abc()
Dim Arr(), i&, Tem, dk$
Arr = Range("B3", [B65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Arr)
      dk = Arr(i, 1)
      If Not .exists(dk) Then
         .Add dk, i & "#" & 1
      Else
         If Not IsNumeric(.Item(dk)) Then
            Tem = Split(.Item(dk), "#")
            Arr(Tem(0), 1) = Arr(Tem(0), 1) & "*01"
            .Item(dk) = 2
            Arr(i, 1) = Arr(i, 1) & "*02"
         Else
            .Item(dk) = .Item(dk) + 1
            Arr(i, 1) = dk & "*" & Format(.Item(dk), "00")
         End If
      End If
   Next
End With
[E3].Resize(i - 1) = Arr
End Sub

Ý tưởng thì đúng rồi đó. Nhưng có lẽ bạn chưa làm qua các mẹo liên quan đến chỉ số mảng cho nên cách giải quyết hơi rườm rà 1 chút.

Nguyên tắc: số đếm và chỉ số mảng luôn luôn dương. Vì vậy ta chỉ cần lần đầu tiên khi ghi key, ghi item với trị -i
Lúc lôi item ra trở lại thì xét dấu. Nếu < 0 thì đó là lần đầu tiên, và đổi dấu để lấy chỉ số của phần tử này.

Mã:

Sub VeVoi()
[COLOR=#008000]' gán duôi 01, 02, ... vào các mã số bị trùng
[/COLOR]Dim a
Dim i As Integer, t As Integer
a = Range("B3:B" & Range("B" & Columns(2).Rows.Count).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
        If .Exists(a(i, 1)) Then
            t = .Item(a(i, 1))
            If t < 0 Then [COLOR=#008000]' món đầu tiên của nhóm trùng[/COLOR]
                a(-t, 1) = a(-t, 1) & "01"
                t = 1
            End If
            t = t + 1
            .Item(a(i, 1)) = t
            a(i, 1) = a(i, 1) & Format(t, "0#")[COLOR=#008000] ' các món kể từ 2 trở đi[/COLOR]
        Else
            .Add a(i, 1), -i [COLOR=#008000]' xuất hiện lần đầu tiên, ghi lại chỉ số thay vì 1[/COLOR]
        End If
    Next i
End With
Range("D3").Resize(UBound(a), 1) = a
End Sub

Ba Tê · 19/12/14

quanghai1969 đã viết:

Bài này muốn gọn thì không hiệu quả, hiệu quả thì lại hơi lằng nhằng
Thử món Dic này

PHP:

Sub abc()
Dim Arr(), i&, Tem, dk$
Arr = Range("B3", [B65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Arr)
      dk = Arr(i, 1)
      If Not .exists(dk) Then
         .Add dk, i & "#" & 1
      Else
         If Not IsNumeric(.Item(dk)) Then
            Tem = Split(.Item(dk), "#")
            Arr(Tem(0), 1) = Arr(Tem(0), 1) & "*01"
            .Item(dk) = 2
            Arr(i, 1) = Arr(i, 1) & "*02"
         Else
            .Item(dk) = .Item(dk) + 1
            Arr(i, 1) = dk & "*" & Format(.Item(dk), "00")
         End If
      End If
   Next
End With
[E3].Resize(i - 1) = Arr
End Sub

Nó muốn kiểu "lằng nhằng" thì cứ "lằng nhằng", nó chạy chứ đâu phải mình chạy.
Cho nó chạy thêm 1 kiểu.
Ẹc...

PHP:

Public Sub GPE()
Dim Dic As Object, Arr(), I As Long, Num As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range([B3], [B3].End(xlDown)).Value
For I = 1 To UBound(Arr, 1)
    Tem = Arr(I, 1)
    If Not Dic.Exists(Tem) Then
        Dic.Add Tem, I
        Arr(I, 1) = Tem
    Else
        If IsNumeric(Dic.Item(Tem)) Then
            Arr(Dic.Item(Tem), 1) = Tem & "01"
            Dic.Item(Tem) = Tem & "01"
        End If
        Num = Val(Right(Dic.Item(Tem), 2))
        Dic.Item(Tem) = Tem & Format(Num + 1, "00")
        Arr(I, 1) = Dic.Item(Tem)
    End If
Next I
[F3].Resize(I - 1) = Arr
Set Dic = Nothing
End Sub

sealand · 19/12/14

Mình tham gia 1 cách:

Mã:

Sub Test()
Dim Rg As Range, Tm, i
 Set Rg = Sheet1.Range("B3:B" & [B65536].End(3).Row)
 Tm = Rg
  For i = 1 To UBound(Tm, 1)
       If WorksheetFunction.CountIf(Rg, Tm(i, 1)) > 1 Then
          Tm(i, 1) = Tm(i, 1) & Format(WorksheetFunction.CountIf( _
         Rg.Cells(1, 1).Resize(i), Tm(i, 1)), "00")
       End If
  Next
Rg.Offset(, 5) = Tm
Set Rg = Nothing
End Sub

Đây là mình để cột kết quả trên cột G để kiểm tra nên dùng câu lệnh

Rg.Offset(, 5) = Tm

Như bạn muốn đè luôn kết quả vào chính cột B thì chỉ việc thay:

Rg=Tm

Cần giúp viết Code thêm ký tự 01, 02, 03,... vào bên phải những ô trùng nhau (2 người xem)

Người dùng đang xem chủ đề này

hung2412

Thành viên tích cực

File đính kèm

Hau151978

Thành viên tích cực

sealand

Thành viên gạo cội

hung2412

Thành viên tích cực

hung2412

Thành viên tích cực

Hau151978

Thành viên tích cực

hung2412

Thành viên tích cực

Hau151978

Thành viên tích cực

hung2412

Thành viên tích cực

SA_DQ

/(hông là gì!

VetMini

Đang đi tìm hòn đá

Quang_Hải

Thành viên gạo cội

VetMini

Đang đi tìm hòn đá

Ba Tê

Cạo Rồi Khỏi Gội

sealand

Thành viên gạo cội

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.