Đánh số tự động trong exel bằng VBA (Help !) :( (1 người xem)

[tuan.vn.com]

Chào các bác, đầu tiên e xin gửi lời cám ơn đến các anh chị nhờ diễn đàn e cũng học hỏi được rất nhiều kinh nghiệm quý báu, tuy nhiên e vẫn còn gà quá. Hum nay e mạo muội lên nhờ a chị giúp e giải bài toán bằng code VBA mà e nghĩ mãi không được.

b1: Đánh số ô C2 = 1
duyệt các dòng từ a2 đến hết nếu các dòng bên dưới có đường kính và chiều dài giống bên trên thì cho đánh số hiệu giống dòng bên trên.
b2: nếu không trùng thì cho số hiệu nhảy thêm 1 đơn vị

Cụ thể : ô C2 =1
dòng 3 có a2 và b2 khác dòng 2 nên số hiệu tăng lên 1 (C3=2)
dòng 4 giống dòng 2 nên c4 =1
dòng 5 không giống dòng nào bên trên nên số hiệu tăng lên 1 (C5=3)
dòng 6 giống dòng 3 nên (C6=2)
........
Em gửi file đính kèm mong các bác giúp e với ạ

 

[PacificPR]

Chào các bác, đầu tiên e xin gửi lời cám ơn đến các anh chị nhờ diễn đàn e cũng học hỏi được rất nhiều kinh nghiệm quý báu, tuy nhiên e vẫn còn gà quá. Hum nay e mạo muội lên nhờ a chị giúp e giải bài toán bằng code VBA mà e nghĩ mãi không được.

b1: Đánh số ô C2 = 1
duyệt các dòng từ a2 đến hết nếu các dòng bên dưới có đường kính và chiều dài giống bên trên thì cho đánh số hiệu giống dòng bên trên.
b2: nếu không trùng thì cho số hiệu nhảy thêm 1 đơn vị

Cụ thể : ô C2 =1
dòng 3 có a2 và b2 khác dòng 2 nên số hiệu tăng lên 1 (C3=2)
dòng 4 giống dòng 2 nên c4 =1
dòng 5 không giống dòng nào bên trên nên số hiệu tăng lên 1 (C5=3)
dòng 6 giống dòng 3 nên (C6=2)
........
Em gửi file đính kèm mong các bác giúp e với ạ

Bạn chạy thử cái này xem

Sub Danhsohieu()
    Dim sArr, dArr, I As Long, K As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("A2", .Range("A65535").End(3)).Resize(, 2).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty And sArr(I, 2) <> Empty Then
            Tem = sArr(I, 1) & "#" & sArr(I, 2)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add Tem, I
                dArr(I, 1) = K
            Else
                dArr(I, 1) = dArr(Dic.Item(Tem), 1)
            End If
        End If
    Next I
    .Range("C2").Resize(I - 1, 1) = dArr
End With
Set Dic = Nothing
End Sub

 

[TheThienChu]

Chào các bác, đầu tiên e xin gửi lời cám ơn đến các anh chị nhờ diễn đàn e cũng học hỏi được rất nhiều kinh nghiệm quý báu, tuy nhiên e vẫn còn gà quá. Hum nay e mạo muội lên nhờ a chị giúp e giải bài toán bằng code VBA mà e nghĩ mãi không được.

b1: Đánh số ô C2 = 1
duyệt các dòng từ a2 đến hết nếu các dòng bên dưới có đường kính và chiều dài giống bên trên thì cho đánh số hiệu giống dòng bên trên.
b2: nếu không trùng thì cho số hiệu nhảy thêm 1 đơn vị

Cụ thể : ô C2 =1
dòng 3 có a2 và b2 khác dòng 2 nên số hiệu tăng lên 1 (C3=2)
dòng 4 giống dòng 2 nên c4 =1
dòng 5 không giống dòng nào bên trên nên số hiệu tăng lên 1 (C5=3)
dòng 6 giống dòng 3 nên (C6=2)
........
Em gửi file đính kèm mong các bác giúp e với ạ

Gửi bạn đọan code gọi là góp vui

Option Explicit

Public Sub Tuan_Vn_Com()
Dim SArr, Res
Dim Cnd(1 To 2, 1 To 48), i As Long, j As Long

With Sheet1
SArr = .Range("A2", .Range("B1000000").End(xlUp))
ReDim Res(1 To UBound(SArr), 1 To 1)
j = 1
For i = 1 To UBound(SArr)
    If SArr(i, 2) = Cnd(1, SArr(i, 1)) Then
        Res(i, 1) = Cnd(2, SArr(i, 1))
    Else
        Res(i, 1) = j
        Cnd(1, SArr(i, 1)) = SArr(i, 2)
        Cnd(2, SArr(i, 1)) = j
        j = j + 1
    End If
Next i
.Range("C2").Resize(UBound(SArr), 1).ClearContents
.Range("C2").Resize(UBound(SArr), 1) = Res
End With
End Sub

 

[tuan.vn.com]

Bạn chạy thử cái này xem

Sub Danhsohieu()
    Dim sArr, dArr, I As Long, K As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("A2", .Range("A65535").End(3)).Resize(, 2).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty And sArr(I, 2) <> Empty Then
            Tem = sArr(I, 1) & "#" & sArr(I, 2)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add Tem, I
                dArr(I, 1) = K
            Else
                dArr(I, 1) = dArr(Dic.Item(Tem), 1)
            End If
        End If
    Next I
    .Range("C2").Resize(I - 1, 1) = dArr
End With
Set Dic = Nothing
End Sub

Nhanh thật, cám ơn bác )

 

[tuan.vn.com]

Gửi bạn đọan code gọi là góp vui

Option Explicit

Public Sub Tuan_Vn_Com()
Dim SArr, Res
Dim Cnd(1 To 2, 1 To 48), i As Long, j As Long

With Sheet1
SArr = .Range("A2", .Range("B1000000").End(xlUp))
ReDim Res(1 To UBound(SArr), 1 To 1)
j = 1
For i = 1 To UBound(SArr)
    If SArr(i, 2) = Cnd(1, SArr(i, 1)) Then
        Res(i, 1) = Cnd(2, SArr(i, 1))
    Else
        Res(i, 1) = j
        Cnd(1, SArr(i, 1)) = SArr(i, 2)
        Cnd(2, SArr(i, 1)) = j
        j = j + 1
    End If
Next i
.Range("C2").Resize(UBound(SArr), 1).ClearContents
.Range("C2").Resize(UBound(SArr), 1) = Res
End With
End Sub

Cám ơn cả bác nữa, hihi tuyệt vời.