Nhờ giúp đỡ Code Chia danh sách hàng hóa trong file excel thành nhiều lần đóng gói (1 người xem)

[anhvuhvnh]

Chào các anh/chị GPE.
E có bài toán liên quan đến việc chia tách các mặt hàng trong danh sách thành 10 lần để đóng gói thành từng đơn hàng xuất cho đối tác.
Điều kiện: Giá trị hàng hóa mỗi lần đóng gói gần tương đương nhau (xấp xỉ tổng giá trị/10 lần tương đương khoảng 200-300tr) , số còn lại dồn vào lần đóng hàng cuối cùng. Sau mỗi lần đóng hàng sẽ đưa danh sách tách được sang sheet khác để in ra làm phiếu xuất kho.
E gửi file đính kèm bên dưới. Mong được các anh chị hỗ trợ.
Trân trọng cảm ơn.

 

[Nhattanktnn]

Chào các anh/chị GPE.
E có bài toán liên quan đến việc chia tách các mặt hàng trong danh sách thành 10 lần để đóng gói thành từng đơn hàng xuất cho đối tác.
Điều kiện: Giá trị hàng hóa mỗi lần đóng gói gần tương đương nhau (xấp xỉ tổng giá trị/10 lần tương đương khoảng 200-300tr) , số còn lại dồn vào lần đóng hàng cuối cùng. Sau mỗi lần đóng hàng sẽ đưa danh sách tách được sang sheet khác để in ra làm phiếu xuất kho.
E gửi file đính kèm bên dưới. Mong được các anh chị hỗ trợ.
Trân trọng cảm ơn.

Bạn thử xem:

Sub Tach()
Application.ScreenUpdating = False
Dim Rng As Range, I&, J&, Lr&
Const SoLan = 10
Lr = Sheets("Sheet1").Range("F" & Rows.Count).End(3).Row
Set Rng = Sheets("Sheet1").Range("A1:F" & Lr)
For I = 1 To SoLan
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = "Lan " & I
        Rng.Copy: .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths: .Paste
            For J = 2 To Lr - 1
                .Range("F" & J).Value = .Range("F" & J).Value / 10
            Next
    End With
Next
Application.ScreenUpdating = True
End Sub

 

[anhvuhvnh]

@Nhattanktnn E thử nhưng code báo lỗi như này bác ah:

 

[Nhattanktnn]

@Nhattanktnn E thử nhưng code báo lỗi như này bác ah:

À mình chạy ok xong rồi mình sửa tí thì lỡ tay xóa mất "Dim", bạn gõ "Dim" và khoảng trống trước chữ Rng nhé.
Hoặc copy lại code phía trên

 

[befaint]

.Name = "Lan " & I

Làm việc với các đối tượng của Workbook cần cẩn thận hơn.
Như kia mình ấn chạy code lần thứ 2 là hỏng.

 

[Nhattanktnn]

Làm việc với các đối tượng của Workbook cần cẩn thận hơn.
Như kia mình ấn chạy code lần thứ 2 là hỏng.

Cảm ơn góp ý của bác, em đang học nên có thể chưa nghĩ tới được nhiều trường hợp xảy ra lỗi. Vậy trong trường hợp này em nên đặt điều kiện sheets.count> 1 thì xóa sheet có tên khác sheet1 trước khi chạy đúng không bác?

 

[befaint]

trong trường hợp này em nên đặt điều kiện sheets.count> 1 thì xóa sheet có tên khác sheet1 trước khi chạy đúng không bác?

Đó cũng là một cách.

Giả sử file có số sheets bất kỳ, có thể căn cứ theo tên (ký tự) mình đặt mới để xứ lý trước khi chạy code.

 

[Nhattanktnn]

Đó cũng là một cách.

Giả sử file có số sheets bất kỳ, có thể căn cứ theo tên (ký tự) mình đặt mới để xứ lý trước khi chạy code.

Em sửa lại theo góp ý của bác, có gì không hợp lý bác chỉ giúp em nhé:

Sub Tach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Ws As Worksheet, Rng As Range, I&, J&, Lr&
Const SoLan = 10
Lr = Sheets("Sheet1").Range("F" & Rows.Count).End(3).Row
Set Rng = Sheets("Sheet1").Range("A1:F" & Lr)
For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name Like "Lan*" Then Ws.Delete
Next Ws
For I = 1 To SoLan
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = "Lan " & I
        Rng.Copy: .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths: .Paste
            For J = 2 To Lr - 1
                .Range("F" & J).Value = .Range("F" & J).Value / 10
            Next
    End With
Next
Application.CutCopyMode = False
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[VetMini]

... em đang học nên có thể chưa nghĩ tới được nhiều trường hợp xảy ra lỗi. ...

Nếu bạn đang học thì tôi chỉ có một lời khuyên (lưu ý là lời khuyên này chưa hề được một người nào trên GPE để ý đến)

- đây là bài chú trọng về thuật toán. Người giải nên nói sơ qua về thuật toán của mình. Khi có trục trặc gì thì người khác xem qua có thể biết do thuật toán chưa hoàn chỉnh hay do code chưa theo đúng thuật toán.

 

[befaint]

If Ws.Name Like "Lan*" Then Ws.Delete

Nên gán "Lan" vào hằng số, để lên đầu Sub.

Chỗ Like nên dùng hàm Instr() để kiểm tra thì hay hơn.

 

[Nhattanktnn]

Nên gán "Lan" vào hằng số, để lên đầu Sub.

Chỗ Like nên dùng hàm Instr() để kiểm tra thì hay hơn.

Em lại sửa lại chút nữa theo ý bác, nhưng bác cho hỏi chút là, thay instr cho like thì nó hay hơn ở điểm nào ạ? có liên quan gì đến chữ hoa chữ thường không?

Sub Tach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Ws As Worksheet, Rng As Range, I&, J&, Lr&
Const SoLan = 10: sname = "Lan"
Lr = Sheets("Sheet1").Range("F" & Rows.Count).End(3).Row
Set Rng = Sheets("Sheet1").Range("A1:F" & Lr)
For Each Ws In ActiveWorkbook.Sheets
    If InStr(1, Ws.Name, sname) > 0 Then Ws.Delete
Next Ws
For I = 1 To SoLan
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = "Lan " & I
        Rng.Copy: .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths: .Paste
            For J = 2 To Lr - 1
                .Range("F" & J).Value = .Range("F" & J).Value / 10
            Next
    End With
Next
Application.CutCopyMode = False
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[huuthang_bd]

Nếu bạn đang học thì tôi chỉ có một lời khuyên (lưu ý là lời khuyên này chưa hề được một người nào trên GPE để ý đến)

- đây là bài chú trọng về thuật toán. Người giải nên nói sơ qua về thuật toán của mình. Khi có trục trặc gì thì người khác xem qua có thể biết do thuật toán chưa hoàn chỉnh hay do code chưa theo đúng thuật toán.

Thuật toán của các code cho đến hiện tại là lấy tổng thành tiền chia cho số lần, không cần quan tâm đến số lượng . Và kết quả là 10 lần như 1, số lượng mặt hàng, giá trị từng mặt hàng và tổng giá trị các lần đều giống nhau. Code không trả về số lượng từng mặt hàng, khi áp dụng chắc thớt phải tháo rời linh kiện các mặt hàng có số lượng không phải là bội số của số lần ra thì mới chia được

 

[huuthang_bd]

Thuật toán có thể như thế này:

• Chia từ mặt hàng có đơn giá lớn đến nhỏ, chia theo kiểu chia bài, phát mỗi nhóm 1 cái cho đến hết.
• Những nhóm còn thiếu thì chia tiếp các mặt hàng còn lại, cũng theo thứ tự ưu tiêu đơn giá lớn chia trước cho đến khi giá trị bằng (hoặc sấp sỉ) nhóm được chia đủ
• Lặp lại cho đến khi hết hàng.

--
Đính chính thuật toán
Chia mặt hàng có đơn giá lớn nhất trong phần hàng chưa chia cho nhóm có tổng giá trị đã chia nhỏ nhất cho đến khi hết.

 

[huuthang_bd]

Code

Function ChiaHang(SL_DG) As Variant
Dim ViTri As Variant, SoNhom As Long, KetQua As Variant, Tong As Variant
Dim i As Long, j As Long, k As Long
SoNhom = Application.Caller.Columns.Count
SL_DG = SL_DG
ViTri = SapXep(SL_DG)
ReDim KetQua(1 To UBound(SL_DG, 1), 1 To SoNhom)
ReDim Tong(1 To SoNhom)
For i = 1 To UBound(SL_DG, 1)
    For j = 1 To SL_DG(ViTri(i), 1)
        k = NhoNhat(Tong)
        Tong(k) = Tong(k) + SL_DG(ViTri(i), 2)
        KetQua(ViTri(i), k) = KetQua(ViTri(i), k) + 1
    Next
Next
ChiaHang = KetQua
End Function
Private Function NhoNhat(ByRef Tong As Variant) As Long
Dim i As Long
NhoNhat = 1
For i = 2 To UBound(Tong)
    If Tong(i) < Tong(NhoNhat) Then NhoNhat = i
Next
End Function
Private Function SapXep(ByVal SL_DG As Variant) As Variant
Dim ViTri As Variant, i As Long, j As Long, Tmp As Variant
ReDim ViTri(1 To UBound(SL_DG, 1))
For i = 1 To UBound(ViTri, 1)
    ViTri(i) = i
Next
For i = 1 To UBound(SL_DG, 1) - 1
    For j = i + 1 To UBound(SL_DG, 1)
        If SL_DG(j, 2) > SL_DG(i, 2) Then
            Tmp = SL_DG(j, 2): SL_DG(j, 2) = SL_DG(i, 2): SL_DG(i, 2) = Tmp
            Tmp = ViTri(j): ViTri(j) = ViTri(i): ViTri(i) = Tmp
        End If
    Next
Next
SapXep = ViTri
End Function