Mình có một bảng như bên dưới nhờ anh em diễn đàn giúp mình giải bài tập này:
Mình cần nhóm 3 ô giống nhau ở cột A và đánh số thứ tự qua cột B, cứ 3 ô giống nhau thành 1 nhóm sau khi nhóm hết thì 3 ô bất kì chưa được nhóm sẽ vào 1 nhóm. Cảm ơn anh em giúp đỡ
Code cho người muốn xem
Dữ liệu từ ô A2 xuống dưới
Mã:
Sub XYZ()
Dim a(), b, res(), dic As Object, key
Dim sRow&, i&, k&, d&
Set dic = CreateObject("scripting.dictionary")
a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
sRow = UBound(a)
For i = 1 To sRow
If dic.exists(a(i, 1)) = False Then
dic(a(i, 1)) = Array(1, 0, 0, 0)
Else
b = dic(a(i, 1))
b(0) = b(0) + 1
dic(a(i, 1)) = b
End If
Next i
For Each key In dic.keys
b = dic(key)
b(1) = Int(b(0) / 3)
dic(key) = b
Next key
ReDim res(1 To sRow, 1 To 1)
For i = 1 To sRow
b = dic(a(i, 1))
If b(1) > 0 Then
If b(2) = 0 Then
k = k + 1
b(3) = k
End If
b(2) = b(2) + 1
If b(2) = 3 Then
b(1) = b(1) - 1
b(2) = 0
End If
End If
dic(a(i, 1)) = b
res(i, 1) = b(3)
Next i
For i = 1 To sRow
If res(i, 1) = Empty Then
If d = 0 Then k = k + 1
If d = 2 Then d = 0 Else d = d + 1
res(i, 1) = k
End If
Next i
Range("B2").Resize(sRow) = res
End Sub
Sub Combine_Material()
Dim i, j, k, l, lr As Integer
lr = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Sheet1.Range("A2:A" & lr).ClearContents
Sheet1.Range("C2").Formula = "=COUNTIF($B$2:B2,B2)"
Sheet1.Range("C2:C" & lr).FillDown
Sheet1.Range("C2:C" & lr).Value = Sheet1.Range("C2:C" & lr).Value
With Sheet1
k = 0
l = 0
For i = 2 To lr
If .Range("C" & i).Value Mod 3 = 0 Then
k = k + 1
For j = 2 To i
If .Cells(j, 2).Value = .Cells(i, 2).Value And .Cells(j, 1).Value = "" Then .Cells(j, 1).Value = "T" & k
Next j
End If
Next i
.Range("C2").Formula = "=if(A2<>"""","""",COUNTIF($A$2:A2,""""))"
.Range("C2:C" & lr).FillDown
.Range("C2:C" & lr).Value = .Range("C2:C" & lr).Value
For i = 2 To lr
If .Cells(i, 3).Value Mod 3 = 0 And .Cells(i, 3).Value <> "" Then
k = k + 1
For j = 2 To i
If .Cells(j, 1).Value = "" Then .Cells(j, 1).Value = "T" & k
Next j
End If
Next i
k = k + 1
For i = 2 To lr
If .Cells(i, 1).Value = "" Then .Cells(i, 1).Value = "T" & k
Next i
.Range("C2:C" & lr).ClearContents
End With
End Sub
Bài đã được tự động gộp:
@HieuCD Cảm ơn bác đã bỏ thời gian nghiên cứu giùm mình. Bác có thể giải thích một chút về cách của bác không
Sub Combine_Material()
Dim i, j, k, l, lr As Integer
lr = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Sheet1.Range("A2:A" & lr).ClearContents
Sheet1.Range("C2").Formula = "=COUNTIF($B$2:B2,B2)"
Sheet1.Range("C2:C" & lr).FillDown
Sheet1.Range("C2:C" & lr).Value = Sheet1.Range("C2:C" & lr).Value
With Sheet1
k = 0
l = 0
For i = 2 To lr
If .Range("C" & i).Value Mod 3 = 0 Then
k = k + 1
For j = 2 To i
If .Cells(j, 2).Value = .Cells(i, 2).Value And .Cells(j, 1).Value = "" Then .Cells(j, 1).Value = "T" & k
Next j
End If
Next i
.Range("C2").Formula = "=if(A2<>"""","""",COUNTIF($A$2:A2,""""))"
.Range("C2:C" & lr).FillDown
.Range("C2:C" & lr).Value = .Range("C2:C" & lr).Value
For i = 2 To lr
If .Cells(i, 3).Value Mod 3 = 0 And .Cells(i, 3).Value <> "" Then
k = k + 1
For j = 2 To i
If .Cells(j, 1).Value = "" Then .Cells(j, 1).Value = "T" & k
Next j
End If
Next i
k = k + 1
For i = 2 To lr
If .Cells(i, 1).Value = "" Then .Cells(i, 1).Value = "T" & k
Next i
.Range("C2:C" & lr).ClearContents
End With
End Sub
Bài đã được tự động gộp:
@HieuCD Cảm ơn bác đã bỏ thời gian nghiên cứu giùm mình. Bác có thể giải thích một chút về cách của bác không
Dùng Dic nhằm giảm số lần duyệt các giá trị nhằm tăng tốc xử lý khi dữ liệu lớn. Tương tự cách dùng cột phụ, dic(a(i, 1)) = Array(1, 0, 0, 0) dùng 4 "cột phụ" (có thể chỉ cần 2), cách xử lý khá phức tạp, xem ghi chú trong code
Mã:
Sub XYZ()
Dim a(), b, res(), dic As Object, key
Dim sRow&, i&, k&, d&
Set dic = CreateObject("scripting.dictionary")
a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
sRow = UBound(a)
For i = 1 To sRow 'Dem so lan trung
If dic.exists(a(i, 1)) = False Then
dic(a(i, 1)) = Array(1, 0, 0, 0) 'Item là mang có 4 cot(0 to 3)
Else
b = dic(a(i, 1))
b(0) = b(0) + 1 'dem so lan trung
dic(a(i, 1)) = b
End If
Next i
For Each key In dic.keys 'Dem so nhom cac dong trung >= 3 lan
b = dic(key)
b(1) = Int(b(0) / 3) 'So nhom trung 3 lan
dic(key) = b
Next key
ReDim res(1 To sRow, 1 To 1)
For i = 1 To sRow 'Nhom cac dong trung 3 lan: b(1) > 0
b = dic(a(i, 1))
If b(1) > 0 Then
If b(2) = 0 Then 'dong dau cua nhom 3
k = k + 1
b(3) = k 'Thu tu nhom
End If
b(2) = b(2) + 1
If b(2) = 3 Then 'nhom du 3 dong
b(1) = b(1) - 1 ' giam so nhom
b(2) = 0 'ghi chu nhom 3 moi
End If
End If
dic(a(i, 1)) = b
res(i, 1) = b(3)
Next i
For i = 1 To sRow 'Nhom cac dong còn lai
If res(i, 1) = Empty Then
If d = 0 Then k = k + 1
If d = 2 Then d = 0 Else d = d + 1
res(i, 1) = k
End If
Next i
Range("B2").Resize(sRow) = res
End Sub
Cách khác đơn giản dể hiểu hơn nhưng chạy chậm hơn
Mã:
Sub XYZ()
Dim a(), b(1 To 3) As Long, res() As Long, key
Dim sRow&, i&, r&, c&, j&, k&
a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
sRow = UBound(a)
ReDim res(1 To sRow, 1 To 1)
For i = 1 To sRow 'nhom cac dong trung 3 lan
key = a(i, 1)
If key <> Empty Then
c = 0
For r = i To sRow 'Do cac dong trung key
If a(r, 1) = key Then
c = c + 1 'dem so lan trung
b(c) = r
If c = 3 Then 'Neu trung 3 lan
k = k + 1
For j = 1 To 3 'ghi ket qua nhom
res(b(j), 1) = k
a(b(j), 1) = Empty 'Loai bo dong da nhom
Next j
Exit For
End If
End If
Next r
End If
Next i
c = 0
For i = 1 To sRow 'Nhom cac dong con lai
If res(i, 1) = Empty Then 'Ket qua chua duoc nhom
If c = 0 Then k = k + 1
If c = 2 Then c = 0 Else c = c + 1
res(i, 1) = k
End If
Next i
Range("B2").Resize(sRow) = res
End Sub
