[Nhờ code] Phân dòng theo template

[castanea]

Hi mọi người.
Em đang có file như sau:
1- Dữ lieu có sẳn ở 2 sheet Danh muc và Template
2- Cần kết hợp 2 sheet trên để ra sheet chi tiết. Kết quả em cần làm là ở sheet Chi tiết (Ket qua)
Vì số dòng bước kiểm tra không đồng nhất nên em không thể dung hàm được

Nhờ các ACE giúp em xử lý vấn đề.
File chỉ ví dụ 1 phần dữ lieu của em thôi, phân loại nhóm em có hơn 50 nhóm thao tác khác nhau, và hơn 1000 mặt hang. hiện tại em đang phải copy paste tay cho từng trường hợp nên rất lâu

Cám ơn moi người

 

[HieuCD]

Hi mọi người.
Em đang có file như sau:
1- Dữ lieu có sẳn ở 2 sheet Danh muc và Template
2- Cần kết hợp 2 sheet trên để ra sheet chi tiết. Kết quả em cần làm là ở sheet Chi tiết (Ket qua)
Vì số dòng bước kiểm tra không đồng nhất nên em không thể dung hàm được

Nhờ các ACE giúp em xử lý vấn đề.
File chỉ ví dụ 1 phần dữ lieu của em thôi, phân loại nhóm em có hơn 50 nhóm thao tác khác nhau, và hơn 1000 mặt hang. hiện tại em đang phải copy paste tay cho từng trường hợp nên rất lâu

Cám ơn moi người

Sub Chitiet()
Dim DanhMuc(), Template(), Res(), S
Dim i As Long, ik As Long, n As Long
Dim iKey
With Sheets("Danh muc")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i < 2 Then Exit Sub
DanhMuc = .Range("A2:C" & i).Value
End With
With Sheets("template")
i = .Range("B" & Rows.Count).End(xlUp).Row
If i < 2 Then Exit Sub
Template = .Range("A2:C" & i + 1).Value
ReDim Res(1 To UBound(DanhMuc) * Application.Max(.Range("B2:B" & i)), 1 To 4)
End With

With CreateObject("scripting.dictionary")
For i = 1 To UBound(Template) - 1
iKey = Template(i, 1)
If Len(Template(i + 1, 1)) = 0 Then Template(i + 1, 1) = iKey
.Item(iKey) = .Item(iKey) & "," & i
Next i
k = 1
For i = 1 To UBound(DanhMuc)
iKey = DanhMuc(i, 3)
If .exists(iKey) Then
S = Split(.Item(iKey), ",")
Res(k, 1) = DanhMuc(i, 1)
Res(k, 2) = DanhMuc(i, 2)
For n = 1 To UBound(S)
ik = S(n)
Res(k, 3) = Template(ik, 2)
Res(k, 4) = Template(ik, 3)
k = k + 1
Next n
End If
Next i
End With
With Sheets("Chi tiet")
i = .Range("D" & Rows.Count).End(xlUp).Row
If i > 1 Then .Range("A2" & i).ClearContents
.Range("A22").Resize(k - 1) = Res
End With
End Sub

 

[castanea]

Cảm ơn anh rất nhiều, em xem có gì không biết hỏi thêm anh giải thích giúp em nhé ^_^