Phân bổ số lượng lãnh hàng

Liên hệ QC
Y

YenNhi195

Thành viên mới
Tham gia
28/2/22
Bài viết
21
Được thích
4
Chào anh chị ạ, Nhờ anh chị giúp đỡ em một vấn đề như này,em làm thủ công tốn thời gian quá. em cảm ơn.
Phân bổ số lượng lãnh hàng
Yêu cầu:
1/ Chia số thùng và hộp theo dữ liệu sheet TIẾN ĐỘ,
1.1/ Loại hàng
Jr: lấy size hàng dưới (E2:AA2).
Men: lấy size hàng trên (E1:AA1).
2/ Điều kiện chia ở sheet tiêu chuẩn:
Đơn hàng, Hình thể,size,loại hàng,tên thùng,tên hộp,tổng số đôi, tổng số thùng, đôi/thùng).
2.1/ Một đơn hàng chia nhiều lần lãnh nhưng tiêu chuẩn thì là tổng số của một đơn hàng nên cần chia để ra các lần lãnh khác nhau.
2.2/ Chia hết đơn hàng ở Tiến độ phải khớp với số lượng Đôi, thùng, hộp ở tiêu chuẩn.
2.3/ Một size có thể có nhiều loại thùng hộp khác nhau.
3/ Kết quả mẫu như sheet bảng in
3.1/ Dữ liệu trả về là: SL thùng/SL đôi Tên thùng/Tên Hộp (Mục đích là để người đóng gói không làm sai tiêu chuẩn khách hàng).
VD: size 10C lần lãnh thứ 1 có: 6 thùng, 36 hộp, tên thùng X14, tên hộp 13B14
 

File đính kèm

  • Thung&hop.xlsx
    35.4 KB · Đọc: 16
Sắp xếp theo thời gian sắp xếp theo bầu chọn
YenNhi195 đã viết:
Chào anh chị ạ, Nhờ anh chị giúp đỡ em một vấn đề như này,em làm thủ công tốn thời gian quá. em cảm ơn.
Phân bổ số lượng lãnh hàng
Yêu cầu:
1/ Chia số thùng và hộp theo dữ liệu sheet TIẾN ĐỘ,
1.1/ Loại hàng
Jr: lấy size hàng dưới (E2:AA2).
Men: lấy size hàng trên (E1:AA1).
2/ Điều kiện chia ở sheet tiêu chuẩn:
Đơn hàng, Hình thể,size,loại hàng,tên thùng,tên hộp,tổng số đôi, tổng số thùng, đôi/thùng).
2.1/ Một đơn hàng chia nhiều lần lãnh nhưng tiêu chuẩn thì là tổng số của một đơn hàng nên cần chia để ra các lần lãnh khác nhau.
2.2/ Chia hết đơn hàng ở Tiến độ phải khớp với số lượng Đôi, thùng, hộp ở tiêu chuẩn.
2.3/ Một size có thể có nhiều loại thùng hộp khác nhau.
3/ Kết quả mẫu như sheet bảng in
3.1/ Dữ liệu trả về là: SL thùng/SL đôi Tên thùng/Tên Hộp (Mục đích là để người đóng gói không làm sai tiêu chuẩn khách hàng).
VD: size 10C lần lãnh thứ 1 có: 6 thùng, 36 hộp, tên thùng X14, tên hộp 13B14
Nhấp chuột vào đây để mở rộng...
Thử code kết quả khác với của bạn 1 chút.Mà chưa tính tổng hợp.
Mã: 
Sub laychitiet()
    Dim i As Long, lr As Long, dic As Object, dk As String, data, b As Long, arr, j As Long, s As String, T, a As Long, k As Long
    Dim d As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A3:I" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 4)
             If Not dic.exists(dk) Then
                dic.Add dk, "#" & i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
   End With
   With Sheet3
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:AB" & lr).Value
        For i = 3 To UBound(arr)
            For j = 5 To UBound(arr, 2) - 1
                If arr(i, j) > 0 Then
                   If arr(i, 4) = "Jr" Then
                      dk = arr(i, 1) & arr(i, 2) & arr(2, j) & arr(i, 4)
                   Else
                      dk = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(i, 4)
                   End If
                   If dic.exists(dk) Then
                      T = Split(dic.Item(dk), "#")
                      For k = 1 To UBound(T)
                          If k = 1 Then a = arr(i, j)
                          b = T(k)
                          If a > 0 Then
                             c = c + 1
                             If c > 1 Then
                                d = data(b, 9)
                             Else
                                d = a
                             End If
                             s = s & ChrW(10) & a \ data(b, 9) & "/" & d & ChrW(10) & data(b, 5) & "/" & data(b, 6)
                          End If
                            a = a Mod data(b, 9)
                      Next k
                          arr(i, j) = Right(s, Len(s) - 1)
                          s = Empty
                          c = 0
                  End If
                End If
            Next j
       Next i
  End With
  With Sheet1
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Range("b2:Ac" & lr).ClearContents
       .Range("b2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
  End With
  Set dic = Nothing
End Sub
 
Upvote 0
snow25 đã viết:
Thử code kết quả khác với của bạn 1 chút.Mà chưa tính tổng hợp.
Mã: 
Sub laychitiet()
    Dim i As Long, lr As Long, dic As Object, dk As String, data, b As Long, arr, j As Long, s As String, T, a As Long, k As Long
    Dim d As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A3:I" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 4)
             If Not dic.exists(dk) Then
                dic.Add dk, "#" & i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
   End With
   With Sheet3
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:AB" & lr).Value
        For i = 3 To UBound(arr)
            For j = 5 To UBound(arr, 2) - 1
                If arr(i, j) > 0 Then
                   If arr(i, 4) = "Jr" Then
                      dk = arr(i, 1) & arr(i, 2) & arr(2, j) & arr(i, 4)
                   Else
                      dk = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(i, 4)
                   End If
                   If dic.exists(dk) Then
                      T = Split(dic.Item(dk), "#")
                      For k = 1 To UBound(T)
                          If k = 1 Then a = arr(i, j)
                          b = T(k)
                          If a > 0 Then
                             c = c + 1
                             If c > 1 Then
                                d = data(b, 9)
                             Else
                                d = a
                             End If
                             s = s & ChrW(10) & a \ data(b, 9) & "/" & d & ChrW(10) & data(b, 5) & "/" & data(b, 6)
                          End If
                            a = a Mod data(b, 9)
                      Next k
                          arr(i, j) = Right(s, Len(s) - 1)
                          s = Empty
                          c = 0
                  End If
                End If
            Next j
       Next i
  End With
  With Sheet1
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Range("b2:Ac" & lr).ClearContents
       .Range("b2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
  End With
  Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Chào anh,
sau khi em thử thì phát hiện em bị nhằm à. phiền anh sửa lại giúp em chỗ này.
Size (12/3Y) chỉ có 10 đôi thì phải chia là:
1/6
X16/13B16R
1/3
11P3/13B16R
1/1
11P1/13B16R => thì mới đủ 10 đôi ạ.
và size (13.5/4.5Y) và size (14/5Y). sau đó thêm phần tính tổng giúp em với ạ. em cảm ơn.
1647074790459.png
 
Upvote 0
YenNhi195 đã viết:
Chào anh,
sau khi em thử thì phát hiện em bị nhằm à. phiền anh sửa lại giúp em chỗ này.
Size (12/3Y) chỉ có 10 đôi thì phải chia là:
1/6
X16/13B16R
1/3
11P3/13B16R
1/1
11P1/13B16R => thì mới đủ 10 đôi ạ.
và size (13.5/4.5Y) và size (14/5Y). sau đó thêm phần tính tổng giúp em với ạ. em cảm ơn.
View attachment 273031
Nhấp chuột vào đây để mở rộng...
Tuần sau nếu rỗi mình code lại cho.Giờ bận rồi.
 
Upvote 0
YenNhi195 đã viết:
Cảm ơn anh, anh hỗ trợ giúp em với ạ.
Nhấp chuột vào đây để mở rộng...
Thử code.Kết quả có khác với của bạn.
Mã: 
Sub laychitiet()
    Dim i As Long, lr As Long, dic As Object, dk As String, data, b As Long, arr, j As Long, s As String, T, a As Long, k As Long
    Dim d As Long, c As Long, m As Long, n As Long, s1 As String, T1, s2 As String, kq, s3 As String, e As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A3:I" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 4)
             If Not dic.exists(dk) Then
                dic.Add dk, "#" & i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
   End With
   With Sheet3
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:AB" & lr).Value
        For i = 3 To UBound(arr)
            arr(i, 28) = Empty
            For j = 5 To UBound(arr, 2) - 1
                If arr(i, j) > 0 Then
                   If arr(i, 4) = "Jr" Then
                      dk = arr(i, 1) & arr(i, 2) & arr(2, j) & arr(i, 4)
                   Else
                      dk = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(i, 4)
                   End If
                   If dic.exists(dk) Then
                      T = Split(dic.Item(dk), "#")
                      For k = 1 To UBound(T)
                          If k = 1 Then a = arr(i, j)
                          b = T(k)
                          If a > 0 Then
                             d = (a \ data(b, 9)) * data(b, 9)
                             s = s & ChrW(10) & a \ data(b, 9) & "/" & d & ChrW(10) & data(b, 5) & "/" & data(b, 6)
                          End If
                          s1 = data(b, 5) & "/" & data(b, 6)
                          s2 = s1 & "$" & i
                          s3 = arr(i, 28)
                          If a > 0 Then
                          If Not dic.exists(s2) Then
                             m = a \ data(b, 9)
                             n = d
                             dic.Add s2, Array(m, n)
                             arr(i, 28) = arr(i, 28) & "#" & s1
                          Else
                             m = dic.Item(s2)(0) + a \ data(b, 9)
                             n = dic.Item(s2)(1) + d
                             dic.Item(s2) = Array(m, n)
                           End If
                         End If
                            a = a Mod data(b, 9)
                            
                      Next k
                          arr(i, j) = Right(s, Len(s) - 1)
                          s = Empty
                  End If
                End If
            Next j
       Next i
       For i = 3 To UBound(arr)
           T = Split(arr(i, 28), "#")
           arr(i, 28) = Empty
           For k = 1 To UBound(T)
               s1 = T(k) & "$" & i
               If dic.exists(s1) Then
                  arr(i, 28) = arr(i, 28) & ChrW(10) & T(k) & ": " & dic.Item(s1)(0) & "/" & dic.Item(s1)(1)
               End If
           Next k
          If Len(arr(i, 28)) Then arr(i, 28) = Right(arr(i, 28), Len(arr(i, 28)) - 1)
       Next i
      
  End With
  With Sheet1
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Range("b2:Ac" & lr).ClearContents
       .Range("b2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
  End With
  Set dic = Nothing
End Sub
 
Upvote 0
snow25 đã viết:
Thử code.Kết quả có khác với của bạn.
Mã: 
Sub laychitiet()
    Dim i As Long, lr As Long, dic As Object, dk As String, data, b As Long, arr, j As Long, s As String, T, a As Long, k As Long
    Dim d As Long, c As Long, m As Long, n As Long, s1 As String, T1, s2 As String, kq, s3 As String, e As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheet2
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         data = .Range("A3:I" & lr).Value
         For i = 1 To UBound(data)
             dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 4)
             If Not dic.exists(dk) Then
                dic.Add dk, "#" & i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
   End With
   With Sheet3
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:AB" & lr).Value
        For i = 3 To UBound(arr)
            arr(i, 28) = Empty
            For j = 5 To UBound(arr, 2) - 1
                If arr(i, j) > 0 Then
                   If arr(i, 4) = "Jr" Then
                      dk = arr(i, 1) & arr(i, 2) & arr(2, j) & arr(i, 4)
                   Else
                      dk = arr(i, 1) & arr(i, 2) & arr(1, j) & arr(i, 4)
                   End If
                   If dic.exists(dk) Then
                      T = Split(dic.Item(dk), "#")
                      For k = 1 To UBound(T)
                          If k = 1 Then a = arr(i, j)
                          b = T(k)
                          If a > 0 Then
                             d = (a \ data(b, 9)) * data(b, 9)
                             s = s & ChrW(10) & a \ data(b, 9) & "/" & d & ChrW(10) & data(b, 5) & "/" & data(b, 6)
                          End If
                          s1 = data(b, 5) & "/" & data(b, 6)
                          s2 = s1 & "$" & i
                          s3 = arr(i, 28)
                          If a > 0 Then
                          If Not dic.exists(s2) Then
                             m = a \ data(b, 9)
                             n = d
                             dic.Add s2, Array(m, n)
                             arr(i, 28) = arr(i, 28) & "#" & s1
                          Else
                             m = dic.Item(s2)(0) + a \ data(b, 9)
                             n = dic.Item(s2)(1) + d
                             dic.Item(s2) = Array(m, n)
                           End If
                         End If
                            a = a Mod data(b, 9)
                           
                      Next k
                          arr(i, j) = Right(s, Len(s) - 1)
                          s = Empty
                  End If
                End If
            Next j
       Next i
       For i = 3 To UBound(arr)
           T = Split(arr(i, 28), "#")
           arr(i, 28) = Empty
           For k = 1 To UBound(T)
               s1 = T(k) & "$" & i
               If dic.exists(s1) Then
                  arr(i, 28) = arr(i, 28) & ChrW(10) & T(k) & ": " & dic.Item(s1)(0) & "/" & dic.Item(s1)(1)
               End If
           Next k
          If Len(arr(i, 28)) Then arr(i, 28) = Right(arr(i, 28), Len(arr(i, 28)) - 1)
       Next i
     
  End With
  With Sheet1
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Range("b2:Ac" & lr).ClearContents
       .Range("b2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
  End With
  Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
em cảm ơn anh rất nhiều
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
194
Đọc
10K
HeSanbi
HeSanbi
OverAC
Gặp gỡ giao lưu tại Hà Nội, chiều ngày 10/11/2025. cùng Ptm0412, OverAC và các anh chị thân thiết.
    • Thích
    • Yêu thích
Trả lời
4
Đọc
112
viethung78
V
Hai Lúa Miền Tây
Nhập liệu, truy vấn dữ liệu qua Internet = VB.Net
    • Thích
2
Trả lời
26
Đọc
10K
phamduyhoang2907
P
P
Connection string cho SQL Express 2005
Trả lời
7
Đọc
7K
phamduyhoang2907
P
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
4
Đọc
168
CHAOQUAY
C
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
Trả lời
2
Đọc
84
HeSanbi
HeSanbi
Quyen182
  • Question
Xin giúp code VBA để chèn ảnh có sẵn trong Excel vào phần comment
Trả lời
0
Đọc
57
Quyen182
Quyen182
B
  • Question
Xin hướng dẫn tách 1 vùng dữ liệu sang thành nhiều sheet
Trả lời
2
Đọc
64
Hoàng Tuấn 868
H
Toanke063
  • Question
Xin hỏi code vba chuyển 1 file pdf bất kì thành ảnh
Trả lời
7
Đọc
152
cantl
C
HeSanbi
  • Đã giải quyết
ZaloExcel v2.91: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
55
Đọc
13K
HeSanbi
HeSanbi
Bebooby
Tách mã sản phẩm trong chuỗi thông tin
Trả lời
2
Đọc
61
NT Ngoc Yen
N
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
8
Đọc
170
thlpro
thlpro
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
3
Đọc
108
huhumalu
H
S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
73
sakurasumo
S
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
655
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
139
ptm0412
ptm0412
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
247
CNKyNguyen
CNKyNguyen
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
9
Đọc
420
vostro 1500
vostro 1500
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
240
yeudoi
yeudoi
OverAC
Thông báo nội dung xấu và bài viết vi phạm nội quy.
19 20 21
Trả lời
416
Đọc
41K
vanle33
vanle33
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom