Tách sheet theo nhiều điều kiện

[AnhThu-1976]

Em chào Thầy/cô và anh/chị, em có đọc vài bài tách 1 sheet thành nhiều sheet, nhưng do bài của em khi tách sheet thì phức tạp hơn, em không làm được nên nhờ Thầy/cô và anh/chị viết giùm code
Em mô tả file ban đầu của em như sau:

+ Lúc đầu file em chỉ có 2 sheet là: MA và GhiChu

+ trong sheet MA thì có nhiều MA HH (viết tắt của mã hàng hóa – cột A)

MA HH là 4 ký tự số bên phải, còn các ký tự A, B, C đầu thì em quy định

A: là cha (đơn vị tính lớn nhất – ví dụ: thùng)

B: : là con (đơn vị tính lớn thứ nhì – ví dụ: lốc)

C: : là cháu (đơn vị tính lớn thứ ba – ví dụ: chai)

Ví dụ: 1 thùng NN Sting vang có 4 lốc, mỗi lốc có 6 chai (thùng là cha, lốc là con và chai là cháu)
Bây giờ em muốn tách sheet MA thành nhiều sheet theo nhóm hàng ( cột J) như sau:

+ Tên sheet mới được tách thì mang tên nhóm: ví dụ sheet tên mới là: 1,2,…

Khi tách sheet thì gán kết quả như sau:

Gán kết quả từ hàng thứ 5 trở xuống

1/ Cột A: Gán MA HH cha (chỉ gán mã hàng hóa cha – nghĩa là mã có chữ A đầu)

2/ Cột B: Gán tên hàng hóa (Tên hàng hóa của cha, con, cháu đều giống nhau nếu cùng 1 mã hàng)

3/ Cột C: gán đơn vị tính của mã hàng hóa cha

4/ Cột D: gán giá bán của mã hàng hóa cha

5/ Cột H: gán đơn vị tính của mã hàng hóa con (nếu không có thì để trống)

6/ Cột I: gán giá bán của mã hàng hóa con (nếu không có thì để trống)

Lưu ý: cột E, F, G, J, K, L thì không gán gì hết (để trống)

Không gán tên, ĐVT, hay giá của Mã hàng hóa cháu

Kết quả mong muốn như file em gởi lên. Em cảm ơn nhiều!

 

[BuiQuangThuan]

Dữ liệu lúc nào cũng đước sắp xếp cha con cháu à

 

[AnhThu-1976]

Dữ liệu lúc nào cũng đước sắp xếp cha con cháu à

Đúng rồi anh, nếu cùng 1 mã thì cha, con rồi đến cháu

 

[bebo021999]

Làm đại, trong khi chờ giải pháp khác tốt hơn.
Nhấn nút "TÁCH" để chạy code nhé

Option Explicit
Sub tachsheet()
Dim lr&, i&, j&, k&, rng, arr(), ws As Worksheet
Sheets("MA").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A13:J" & lr).Value
ReDim arr(1 To UBound(rng), 1 To 10)
For i = 1 To UBound(rng)
    If rng(i, 1) Like "A*" Then
        k = k + 1
        For j = 1 To 4
            arr(k, 10) = rng(i, 10)
            arr(k, j) = rng(i, j)
        Next
    End If
Next
For i = 1 To k
    For j = 1 To UBound(rng)
        If Replace(arr(i, 1), "A", "B") = rng(j, 1) Then
            arr(i, 8) = rng(j, 3): arr(i, 9) = rng(j, 4)
            Exit For
        End If
    Next
Next
For i = 1 To 2
    If Not Evaluate("=ISREF('" & i & "'!A1)") Then
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = i
        Range("A4:I4").Value = Array("MÃ HH", "TÊN HH", "DVT", "GIÁ ", "", "", "", "DVT", "GIÁ ")
    End If
Next
For Each ws In Sheets
    If ws.Name = "1" Or ws.Name = "2" Then
        ws.Range("A5:J10000").Clear
        ws.Range("A5").Resize(k, 10).Value = arr
        For i = k + 4 To 5 Step -1
            If ws.Range("J" & i).Value <> ws.Name Then ws.Range("J" & i).EntireRow.Delete
        Next
        ws.Columns("J").ClearContents
        With ws.Range("A4:I" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
            .Borders.LineStyle = xlContinuous
            .Columns(4).NumberFormat = "#,###"
            .Columns(9).NumberFormat = "#,###"
            .Rows(1).Font.Bold = True
            .Rows(1).HorizontalAlignment = xlCenter
            .EntireColumn.AutoFit
        End With
    End If
Next
End Sub

 

[AnhThu-1976]

Em cảm ơn anh nhiều

Bài đã được tự động gộp: 23/8/22

Làm đại, trong khi chờ giải pháp khác tốt hơn.
Nhấn nút "TÁCH" để chạy code nhé

Option Explicit
Sub tachsheet()
Dim lr&, i&, j&, k&, rng, arr(), ws As Worksheet
Sheets("MA").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A13:J" & lr).Value
ReDim arr(1 To UBound(rng), 1 To 10)
For i = 1 To UBound(rng)
    If rng(i, 1) Like "A*" Then
        k = k + 1
        For j = 1 To 4
            arr(k, 10) = rng(i, 10)
            arr(k, j) = rng(i, j)
        Next
    End If
Next
For i = 1 To k
    For j = 1 To UBound(rng)
        If Replace(arr(i, 1), "A", "B") = rng(j, 1) Then
            arr(i, 8) = rng(j, 3): arr(i, 9) = rng(j, 4)
            Exit For
        End If
    Next
Next
For i = 1 To 2
    If Not Evaluate("=ISREF('" & i & "'!A1)") Then
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = i
        Range("A4:I4").Value = Array("MÃ HH", "TÊN HH", "DVT", "GIÁ ", "", "", "", "DVT", "GIÁ ")
    End If
Next
For Each ws In Sheets
    If ws.Name = "1" Or ws.Name = "2" Then
        ws.Range("A5:J10000").Clear
        ws.Range("A5").Resize(k, 10).Value = arr
        For i = k + 4 To 5 Step -1
            If ws.Range("J" & i).Value <> ws.Name Then ws.Range("J" & i).EntireRow.Delete
        Next
        ws.Columns("J").ClearContents
        With ws.Range("A4:I" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
            .Borders.LineStyle = xlContinuous
            .Columns(4).NumberFormat = "#,###"
            .Columns(9).NumberFormat = "#,###"
            .Rows(1).Font.Bold = True
            .Rows(1).HorizontalAlignment = xlCenter
            .EntireColumn.AutoFit
        End With
    End If
Next
End Sub

Anh ơi, sheet MA của em có đến 11 nhóm chứ không phải 2 nhóm (do em mô tả chưa rỏ) nhờ anh chỉnh code giúp. Em cảm ơn nhiều

 

[BuiQuangThuan]

Em cảm ơn anh nhiều

Bài đã được tự động gộp: 23/8/22

Anh ơi, sheet MA của em có đến 11 nhóm chứ không phải 2 nhóm (do em mô tả chưa rỏ) nhờ anh chỉnh code giúp. Em cảm ơn nhiều

Dữ liệu thật có quan trọng và nhiều không. Định đưa code lên mà thấy rén. Đưa thêm dữ liệu theo như bạn mô tả xem nào

 

[Maika8008]

Dữ liệu thật có quan trọng và nhiều không. Định đưa code lên mà thấy rén. Đưa thêm dữ liệu theo như bạn mô tả xem nào

Cứ làm đại phát đi, có gì phải rén

 

[BuiQuangThuan]

Cứ làm đại phát đi, có gì phải rén

Cũng đoán được combo như thớt nói ở trên. Nên hỏi lại cho chắc chắn. Đỡ mất công 2 bên anh ạ

 

[AnhThu-1976]

Dữ liệu thật có quan trọng và nhiều không. Định đưa code lên mà thấy rén. Đưa thêm dữ liệu theo như bạn mô tả xem nào

Dữ liệu thật thì giống như file demo, nhưng em chỉ đưa ít số liệu lên cho đỡ rối mắt thôi anh ạ.

@bebo021999 em đã chỉnh sửa được rồi ạ. Một lần nữa cảm ơn anh nhiều​

 

[BuiQuangThuan]

Dữ liệu thật thì giống như file demo, nhưng em chỉ đưa ít số liệu lên cho đỡ rối mắt thôi anh ạ.

Thêm 1 cách khác để tham khảo

Sub ABC()
    Dim sArr(), i&, iR&, iRow&, Key, Rng As Range, Sht$, S
    Dim Dic As Object, Ws As Worksheet
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Rng = Sheets("GhiChu").Range("H2:P2")
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    For Each Ws In Worksheets
        If Ws.Name <> "GhiChu" Then
            If Ws.Name <> "MA" Then
                Ws.Delete
            End If
        End If
    Next
    With Sheets("MA")
        iRow = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A13:J" & iRow).Value
        For i = 1 To UBound(sArr)
            If Dic.exists(sArr(i, 10)) = False Then
                Dic.Add (sArr(i, 10)), ""
                Worksheets.Add after:=Sheets("Ma")
                ActiveSheet.Name = sArr(i, 10)
                Rng.Copy ActiveSheet.Range("A4")
            End If
        Next
    End With
    Dic.RemoveAll
    For i = 1 To UBound(sArr)
        Sht = sArr(i, 10)
        Key = Mid(sArr(i, 1), 2, Len(sArr(i, 1)) - 1)
        With Sheets(Sht)
            iR = .Range("A" & Rows.Count).End(3).Row + 1
            If Dic.exists(Key) = False And Left(sArr(i, 1), 1) = "A" Then
                Dic.Item(Key) = iR
                .Range("A" & iR).Value = sArr(i, 1)
                .Range("B" & iR).Value = sArr(i, 2)
                .Range("C" & iR).Value = sArr(i, 3)
                .Range("D" & iR).Value = sArr(i, 4)
            ElseIf Dic.exists(Key) = True And Left(sArr(i, 1), 1) = "B" Then
                S = Dic.Item(Key)
                .Range("H" & S).Value = sArr(i, 3)
                .Range("I" & S).Value = sArr(i, 4)
            End If
        End With
    Next
    Application.ScreenUpdating = 1
    Application.DisplayAlerts = 1
End Sub