điền mã theo điều kiện

[vinh10]

Cả nhà giúp em với ạ. Em muốn điền cho số chạy tự động tăng dần với những tên giống nhau thì sẽ trùng mã số nếu không trùng nhau thì sẽ tiếp tục tăng trùng sẽ lấy mã phía trước

 

[CHAOQUAY]

Cả nhà giúp em với ạ. Em muốn điền cho số chạy tự động tăng dần với những tên giống nhau thì sẽ trùng mã số nếu không trùng nhau thì sẽ tiếp tục tăng trùng sẽ lấy mã phía trước

Đoán đại

Option Explicit

Sub abc()
Dim Nguon
Dim Kq, i, rws
Nguon = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown))
rws = UBound(Nguon)
ReDim Kq(1 To rws, 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
        Kq(i, 1) = .Item(Nguon(i, 1)) + 1
    Next i
End With
With Sheet1
    .Range("A2").Resize(rws, 1).ClearContents
    .Range("A2").Resize(rws, 1) = Kq
End With
End Sub

 

[Nhattanktnn]

Cả nhà giúp em với ạ. Em muốn điền cho số chạy tự động tăng dần với những tên giống nhau thì sẽ trùng mã số nếu không trùng nhau thì sẽ tiếp tục tăng trùng sẽ lấy mã phía trước

Bạn xem lại nội quy và sửa lại tiêu đề đi nhé
Bài này dùng công thức cũng được

 

[vinh10]

Đoán đại

Option Explicit

Sub abc()
Dim Nguon
Dim Kq, i, rws
Nguon = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown))
rws = UBound(Nguon)
ReDim Kq(1 To rws, 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
        Kq(i, 1) = .Item(Nguon(i, 1)) + 1
    Next i
End With
With Sheet1
    .Range("A2").Resize(rws, 1).ClearContents
    .Range("A2").Resize(rws, 1) = Kq
End With
End Sub

Cho em hỏi muốn gán mã VD: KA001 thay cho 1 thì như thế nào vậy ạ

Bài đã được tự động gộp: 24/11/21

Bạn xem lại nội quy và sửa lại tiêu đề đi nhé
Bài này dùng công thức cũng được

Bạn cho mình xin công thức với ạ VD?: mã là KA001

 

[Nhattanktnn]

Cho em hỏi muốn gán mã VD: KA001 thay cho 1 thì như thế nào vậy ạ

Bài đã được tự động gộp: 24/11/21

Bạn cho mình xin công thức với ạ VD?: mã là KA001

Bạn không sửa tiêu đề bài viết à?

 

[vinh10]

Cho em hỏi muốn gán mã VD: KA001 thay cho 1 thì như thế nào vậy ạ

Bài đã được tự động gộp: 24/11/21

Bạn cho mình xin công thức với ạ VD?: mã là KA001

Bạn có thể hướng dẫn mình sửa cho đúng được không ạ

 

[befaint]

Nội quy diễn đàn

You must agree to these terms and rules before using the site.

www.giaiphapexcel.com

 

[CHAOQUAY]

Cho em hỏi muốn gán mã VD: KA001 thay cho 1 thì như thế nào vậy ạ

'If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = "KA" & Right(.Count + 1000, 3)

Bạn tìm dòng trên, thay = dòng dưới.

---
Bài này có lẽ gọi là "điền mã theo điều kiện" chắc không vấn đề gì

 

[befaint]

Nội quy diễn đàn

You must agree to these terms and rules before using the site.

www.giaiphapexcel.com

 

[vinh10]

'If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = "KA" & Right(.Count + 1000, 3)

Bạn tìm dòng trên, thay = dòng dưới.

---
Bài này có lẽ gọi là "điền mã theo điều kiện" chắc không vấn đề gì

Mình đã thay nhưng có vẻ nó không hoạt động

 

[Nhattanktnn]

Bạn cho mình xin công thức với ạ VD?: mã là KA001

A2=IFERROR(INDEX($A$1:A1,MATCH(C2,$C$1:C1,0)),"KA"&TEXT(SUMPRODUCT(1/COUNTIF($A$1:A1,$A$1:A1)),"000"))

 

[CHAOQUAY]

Mình đã thay nhưng có vẻ nó không hoạt động

Code trên sửa chưa hết, sửa lại thế này là chạy được

Option Explicit


Sub abc()
Dim Nguon
Dim Kq, i, rws
Nguon = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown))
rws = UBound(Nguon)
ReDim Kq(1 To rws, 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        'If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
        'Kq(i, 1) = .Item(Nguon(i, 1)) + 1
        If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = "KA" & Right(.Count + 1 + 1000, 3)
        Kq(i, 1) = .Item(Nguon(i, 1))
    Next i
End With
With Sheet1
    .Range("A2").Resize(rws, 1).ClearContents
    .Range("A2").Resize(rws, 1) = Kq
End With
End Sub

 

[vinh10]

Code trên sửa chưa hết, sửa lại thế này là chạy được

Option Explicit


Sub abc()
Dim Nguon
Dim Kq, i, rws
Nguon = Sheet1.Range("C2", Sheet1.Range("C2").End(xlDown))
rws = UBound(Nguon)
ReDim Kq(1 To rws, 1 To 1)
With CreateObject("Scripting.Dictionary")
    For i = 1 To rws
        'If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = .Count
        'Kq(i, 1) = .Item(Nguon(i, 1)) + 1
        If .Exists(Nguon(i, 1)) = False Then .Item(Nguon(i, 1)) = "KA" & Right(.Count + 1 + 1000, 3)
        Kq(i, 1) = .Item(Nguon(i, 1))
    Next i
End With
With Sheet1
    .Range("A2").Resize(rws, 1).ClearContents
    .Range("A2").Resize(rws, 1) = Kq
End With
End Sub

Cảm ơn bạn nhé mình làm được rồi ạ