Điền số thứ tự theo nhóm

[vanlinh_2904]

Chào anh chị diễn đàn!
Nhờ anh chị viết giúp em VBA điền số thứ tự nhóm theo thứ tự tăng dần từ trên xuống, nếu dữ liệu trùng tên thì cùng 1 nhóm và bỏ qua dòng trống. cảm ơn các anh chị nhiều.

 

[CHAOQUAY]

Chào anh chị diễn đàn!
Nhờ anh chị viết giúp em VBA điền số thứ tự nhóm theo thứ tự tăng dần từ trên xuống, nếu dữ liệu trùng tên thì cùng 1 nhóm và bỏ qua dòng trống. cảm ơn các anh chị nhiều.

Chuột phải vào sheettab sheet1, chọn view code, dán đoạn code bên dưới rồi nhập thử cột C

Private Sub Worksheet_Change(ByVal Target As Range)
Dim SArr
Dim i, j, k
Dim rws
If Target.Column = 3 Then
    rws = Range("C1000000").End(xlUp).Row
    SArr = Range("B1:C" & rws)
    For i = 6 To rws
        If j < SArr(i, 1) Then j = SArr(i, 1)
        If SArr(i, 2) = Target Then
            If i <> Target.Row Then
                Target.Offset(, -1) = SArr(i, 1)
                k = 1
                Exit For
            End If
        End If
    Next i
    If k = 0 Then
        If Target.Offset(, -1) = "" Then Target.Offset(, -1) = j + 1
    End If
End If
End Sub

 

[snow25]

Chào anh chị diễn đàn!
Nhờ anh chị viết giúp em VBA điền số thứ tự nhóm theo thứ tự tăng dần từ trên xuống, nếu dữ liệu trùng tên thì cùng 1 nhóm và bỏ qua dòng trống. cảm ơn các anh chị nhiều.

Bạn thử code.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
      Dim arr, i As Long, so As Long, a As Long, lr As Long
      If Not Intersect(Target, Range("C6:C1000")) Is Nothing Then
         If Target.Value <> Empty Then
            lr = Range("C" & Rows.Count).End(xlUp).Row
            arr = Range("B6:C" & lr).Value
            a = Target.Row
            For i = 1 To UBound(arr)
                If arr(i, 2) = Target.Value Then
                   If i <> a - 5 Then
                      Target.Offset(, -1).Value = arr(i, 1)
                      GoTo thoat
                   End If
                End If
                If so < arr(i, 1) Then so = arr(i, 1)
            Next i
            Target.Offset(, -1).Value = so + 1
       End If
     End If
thoat:
       Application.EnableEvents = True
                
End Sub

 

[PacificPR]

Chào anh chị diễn đàn!
Nhờ anh chị viết giúp em VBA điền số thứ tự nhóm theo thứ tự tăng dần từ trên xuống, nếu dữ liệu trùng tên thì cùng 1 nhóm và bỏ qua dòng trống. cảm ơn các anh chị nhiều.

Bạn thử B7 Copy xuống

=IF(C6<>"";IF(COUNTIF($C$5:C6;C6)>1;INDEX($B$5:B5;MATCH(C6;$C$5:C6;0);1);MAX($B$5:B5)+1);"")

 

[vanlinh_2904]

Bạn thử code.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
      Dim arr, i As Long, so As Long, a As Long, lr As Long
      If Not Intersect(Target, Range("C6:C1000")) Is Nothing Then
         If Target.Value <> Empty Then
            lr = Range("C" & Rows.Count).End(xlUp).Row
            arr = Range("B6:C" & lr).Value
            a = Target.Row
            For i = 1 To UBound(arr)
                If arr(i, 2) = Target.Value Then
                   If i <> a - 5 Then
                      Target.Offset(, -1).Value = arr(i, 1)
                      GoTo thoat
                   End If
                End If
                If so < arr(i, 1) Then so = arr(i, 1)
            Next i
            Target.Offset(, -1).Value = so + 1
       End If
     End If
thoat:
       Application.EnableEvents = True
               
End Sub

Bạn xem lại giúp mình nó báo lỗi thế này

 

[PacificPR]

Bạn xem lại giúp mình nó báo lỗi thế này

Nhà họ thích VBA thì thử cái này xem
Code trong WorkSheet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C6:C1000")) Is Nothing Then
        Call SoTT
    End If
End Sub

Code trong Modul

Sub SoTT()
    Dim Dic As Object, sKey As String
    Dim sArr(), dArr(), I As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("C6", Range("C" & Rows.Count).End(xlUp)).Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For I = 1 To UBound(sArr, 1)
    If sArr(I, 1) <> Empty Then
        sKey = Trim(sArr(I, 1))
        If Not Dic.Exists(sKey) Then
            K = K + 1
            Dic.Add sKey, I
            dArr(I, 1) = K
        Else
            dArr(I, 1) = dArr(Dic.Item(sKey), 1)
        End If
    Else
        dArr(I, 1) = ""
    End If
Next I
Range("B6").Resize(I - 1) = dArr
Set Dic = Nothing
End Sub

 

[SA_DQ]

Rỗi việc nên ham hố góp vui:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [C1:C999]) Is Nothing And Target.Value <> "" And Target.Count = 1 Then
    Dim WF As Object, Rng As Range, sRng As Range
    Dim MaxNhom As Long
    
    Set WF = Application.WorksheetFunction
    Set Rng = Range([B5], [B65500].End(xlUp))
    MaxNhom = WF.Max(Rng)
    Set sRng = Rng.Offset(, 1).Find(Target.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Target.Offset(, -1).Value = MaxNhom + 1
    Else
        If sRng.Address = Target.Address Then
            Target.Offset(, -1).Value = MaxNhom + 1
        Else
            Target.Offset(, -1).Value = sRng.Offset(, -1).Value
        End If
    End If
 End If
End Sub

 

[vanlinh_2904]

Rỗi việc nên ham hố góp vui:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C1:C999]) Is Nothing And Target.Value <> "" And Target.Count = 1 Then
    Dim WF As Object, Rng As Range, sRng As Range
    Dim MaxNhom As Long
  
    Set WF = Application.WorksheetFunction
    Set Rng = Range([B5], [B65500].End(xlUp))
    MaxNhom = WF.Max(Rng)
    Set sRng = Rng.Offset(, 1).Find(Target.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Target.Offset(, -1).Value = MaxNhom + 1
    Else
        If sRng.Address = Target.Address Then
            Target.Offset(, -1).Value = MaxNhom + 1
        Else
            Target.Offset(, -1).Value = sRng.Offset(, -1).Value
        End If
    End If
End If
End Sub

Trường hợp đã đánh số nhóm rồi nhưng sau đó sai tên sửa lại, thì dò lại những từ trên xuống dưới ( tất cả những dòng sau ) nếu trùng tên thì cùng 1 nhóm. Hiện giờ khi sửa lại tên nhưng đã có tên trùng phí dưới đã đánh số nhôm nhưng vẫn nhảy nhóm mới. Bạn sửa lại giúp mình nhé

Nhóm	Tên
1	K01
7	A5
3	B1
8	L02
3	B1
5	D1
2	L02
3	B1
2	L02
6	A5

 

[SA_DQ]

Xin lỗi bạn vì trí tưởng tượng mình kém lắm: Bạn nên nói rõ là đang định sửa ô nào, các trị liên quan là như thế nào & muốn nó sẽ như thế nào mới hiểu được. Đừng diễn đạt như Nghị quyết TW đi!

 

[vanlinh_2904]

Xin lỗi bạn vì trí tưởng tượng mình kém lắm: Bạn nên nói rõ là đang định sửa ô nào, các trị liên quan là như thế nào & muốn nó sẽ như thế nào mới hiểu được. Đừng diễn đạt như Nghị quyết TW đi!

Sửa tại ô C8 lại thành tên "A5" thì kết quả là 6. Vì tên “A5” ở ô C18 là 6. Bạn xem lại giúp mình.

 

[SA_DQ]

Bàn thử với con macro sửa lại này:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C1:C999]) Is Nothing And Target.Value <> "" And Target.Count = 1 Then
    Dim WF As Object, Rng As Range, sRng As Range
    Dim MaxNhom As Long
   
    Set WF = Application.WorksheetFunction
    Set Rng = Range([B5], [B65500].End(xlUp))
    MaxNhom = WF.Max(Rng)
    Set Rng = Union(Range([C5], Target.Offset(-1)), Target.Offset(1).Resize(Rng.Rows.Count))
'    MsgBox Rng.Address      '
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Target.Offset(, -1).Value = MaxNhom + 1
    Else
        Target.Offset(, -1).Value = sRng.Offset(, -1).Value
    End If
End If
End Sub