Chia số lượng theo điều kiện (1 người xem)

vanlinh105 · 4/6/22

Nhờ các bậc tiền bối giúp đỡ ạ, em đang cần làm 1 file phân chia số lượng hàng hóa, theo các tiêu chí:
- CN nào có SL tồn dưới MIN thì cần phải chuyển từ CN khác tới.
- CN0 là ưu tiên chuyển, nếu không đủ SL sẽ chuyển hết SL mà CN0 đang có sau đó set tới các CN khác có SL lớn hơn và vẫn thỏa mã điều kiện >MIN. Ví dụ minh họa ở bên dưới.
Các bác giúp em với ạ, em đang thử nhiều cách mà vẫn chưa ra.

snow25 · 4/6/22

vanlinh105 đã viết:
Nhờ các bậc tiền bối giúp đỡ ạ, em đang cần làm 1 file phân chia số lượng hàng hóa, theo các tiêu chí:
- CN nào có SL tồn dưới MIN thì cần phải chuyển từ CN khác tới.
- CN0 là ưu tiên chuyển, nếu không đủ SL sẽ chuyển hết SL mà CN0 đang có sau đó set tới các CN khác có SL lớn hơn và vẫn thỏa mã điều kiện >MIN. Ví dụ minh họa ở bên dưới.
Các bác giúp em với ạ, em đang thử nhiều cách mà vẫn chưa ra.
View attachment 276897

Biết dùng VBA không bạn.

Phuocam · 4/6/22

vanlinh105 đã viết:
Nhờ các bậc tiền bối giúp đỡ ạ, em đang cần làm 1 file phân chia số lượng hàng hóa, theo các tiêu chí:
- CN nào có SL tồn dưới MIN thì cần phải chuyển từ CN khác tới.
- CN0 là ưu tiên chuyển, nếu không đủ SL sẽ chuyển hết SL mà CN0 đang có sau đó set tới các CN khác có SL lớn hơn và vẫn thỏa mã điều kiện >MIN. Ví dụ minh họa ở bên dưới.
Các bác giúp em với ạ, em đang thử nhiều cách mà vẫn chưa ra.

Sản phẩm	CN0	CN1	CN2	CN3	CN4	CN5	CN6	CN7	CN8	MIN
Sản phẩm A	0	10	1	19	18	17	16	15	14	10
Kết quả 1:	0	10	10	10	18	17	16	15	14	10
Kết quả 2:	0	10	10	15	15	15	16	15	14	10

Trường hợp sản phẩm A như trên, bạn muốn kết quả 1 hay kết quả 2?

.

vanlinh105 · 4/6/22

snow25 đã viết:
Biết dùng VBA không bạn.

Em không bác ơi, em chỉ dùng công thức thôi.

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

Phuocam đã viết:
Sản phẩm CN0 CN1 CN2 CN3 CN4 CN5 CN6 CN7 CN8 MIN
Sản phẩm A 0 10 1 19 18 17 16 15 14 10
Kết quả 1: 0 10 10 10 18 17 16 15 14 10
Kết quả 2: 0 10 10 15 15 15 16 15 14 10

Trường hợp sản phẩm A như trên, bạn muốn kết quả 1 hay kết quả 2?

.

Kết quả 1 bác ah, sẽ chia theo CN lớn nhất, nếu không đủ SL sẽ lấy tiếp CN tiếp theo để chia.

snow25 · 4/6/22

vanlinh105 đã viết:
Em không bác ơi, em chỉ dùng công thức thôi.

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

Kết quả 1 bác ah, sẽ chia theo CN lớn nhất, nếu không đủ SL sẽ lấy tiếp CN tiếp theo để chia.

Nghiên cứu cách dùng VBA chạy thử code.

Mã:

Sub dieuchuyen()
   Dim i As Long, lr As Long, arr, j As Long, a As Long, b As Long, c As Long, k As Long, min As Long, max As Integer, d As Long
   With Sheets("sheet1")
        arr = .Range("B2:K10").Value
        For i = 1 To UBound(arr)
            min = arr(i, 10)
            a = arr(i, 1)
quaylai:
            For j = 2 To 9
                If arr(i, j) < min Then
                   b = min - arr(i, j)
                   If a Then
                      If b <= a Then
                         arr(i, j) = min
                         a = a - b
                      Else
                         arr(i, j) = arr(i, j) + a
                         a = 0
                         d = d + 1
                         If d < 10000 Then GoTo quaylai
                      End If
                   Else
                      For k = 2 To 9
                          If arr(i, k) > min Then
                             If arr(i, k) - min > max Then
                                max = arr(i, k) - min
                                c = k
                             End If
                          End If
                      Next k
                      If b <= max Then
                         arr(i, j) = min
                         arr(i, c) = arr(i, c) - b
                         max = 0
                      Else
                         arr(i, j) = arr(i, j) + max
                         arr(i, c) = min
                         max = 0
                         d = d + 1
                         If d < 10000 Then GoTo quaylai
                      End If
                   End If
               End If
            Next j
            arr(i, 1) = a
       Next i
       .Range("B2:K10").Value = arr
 End With
End Sub

VetMini · 4/6/22

vanlinh105 đã viết:
Nhờ các bậc tiền bối giúp đỡ ạ, em đang cần làm 1 file phân chia số lượng hàng hóa, theo các tiêu chí:
...

Nói với người không thân quen mà dùng loại ngôn ngữ này thì hoặc là châm biếm (đã sẵn thành kiến), hoặc bất cẩn (cẩu thả, không cần xét người đối diện).

HieuCD · 5/6/22

vanlinh105 đã viết:
Nhờ các bậc tiền bối giúp đỡ ạ, em đang cần làm 1 file phân chia số lượng hàng hóa, theo các tiêu chí:
- CN nào có SL tồn dưới MIN thì cần phải chuyển từ CN khác tới.
- CN0 là ưu tiên chuyển, nếu không đủ SL sẽ chuyển hết SL mà CN0 đang có sau đó set tới các CN khác có SL lớn hơn và vẫn thỏa mã điều kiện >MIN. Ví dụ minh họa ở bên dưới.
Các bác giúp em với ạ, em đang thử nhiều cách mà vẫn chưa ra.

Code xét ưu tiên chuyển CN0, sau đó tới CN có sản lượng lớn nhất
kết quả gồm 2 bảng

Mã:

Sub ABC()
  Dim sRow&, sCol&, i&, j&, k&, c, jC&, iMin#, sl#
  Dim arr(), res()
 
  arr = Range("A1", Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Value
  sRow = UBound(arr): sCol = UBound(arr, 2)
  ReDim res(1 To sRow * sCol, 1 To 4)
  For i = 2 To sRow
    iMin = arr(i, sCol)
    For j = 3 To sCol
      Do While arr(i, j) < iMin
        sl = iMin: jC = 0
        If arr(i, 2) = 0 Then
          For c = 3 To sCol - 1
            If sl < arr(i, c) Then
              jC = c
              sl = arr(i, c)
            End If
          Next c
          sl = sl - iMin
        Else
          jC = 2
          sl = arr(i, 2)
        End If
        If sl > 0 Then
          k = k + 1
          res(k, 1) = arr(i, 1)
          res(k, 2) = arr(1, jC)
          res(k, 3) = arr(1, j)
          If sl >= (iMin - arr(i, j)) Then
            arr(i, jC) = arr(i, jC) - (iMin - arr(i, j))
            res(k, 4) = iMin - arr(i, j)
            arr(i, j) = iMin
          Else
            arr(i, jC) = arr(i, jC) - sl
            arr(i, j) = arr(i, j) + sl
            res(k, 4) = sl
          End If
        Else
          Exit Do
        End If
      Loop
    Next j
  Next i
  i = Range("M99999").End(xlUp).Row
  If i > 11 Then Range("M2:P" & i).ClearContents
  If k Then
    Range("M2").Resize(k, 4) = res
    Range("A13").Resize(sRow, sCol) = arr
  End If
End Sub

vanlinh105 · 5/6/22

HieuCD đã viết:

Code xét ưu tiên chuyển CN0, sau đó tới CN có sản lượng lớn nhất
kết quả gồm 2 bảng

Mã:

Sub ABC()
  Dim sRow&, sCol&, i&, j&, k&, c, jC&, iMin#, sl#
  Dim arr(), res()
 
  arr = Range("A1", Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Value
  sRow = UBound(arr): sCol = UBound(arr, 2)
  ReDim res(1 To sRow * sCol, 1 To 4)
  For i = 2 To sRow
    iMin = arr(i, sCol)
    For j = 3 To sCol
      Do While arr(i, j) < iMin
        sl = iMin: jC = 0
        If arr(i, 2) = 0 Then
          For c = 3 To sCol - 1
            If sl < arr(i, c) Then
              jC = c
              sl = arr(i, c)
            End If
          Next c
          sl = sl - iMin
        Else
          jC = 2
          sl = arr(i, 2)
        End If
        If sl > 0 Then
          k = k + 1
          res(k, 1) = arr(i, 1)
          res(k, 2) = arr(1, jC)
          res(k, 3) = arr(1, j)
          If sl >= (iMin - arr(i, j)) Then
            arr(i, jC) = arr(i, jC) - (iMin - arr(i, j))
            res(k, 4) = iMin - arr(i, j)
            arr(i, j) = iMin
          Else
            arr(i, jC) = arr(i, jC) - sl
            arr(i, j) = arr(i, j) + sl
            res(k, 4) = sl
          End If
        Else
          Exit Do
        End If
      Loop
    Next j
  Next i
  i = Range("M99999").End(xlUp).Row
  If i > 11 Then Range("M2:P" & i).ClearContents
  If k Then
    Range("M2").Resize(k, 4) = res
    Range("A13").Resize(sRow, sCol) = arr
  End If
End Sub

Đúng cái em đang cần rồi bác ạ

Nhưng em đang cần thêm điều kiện nữa là mỗi CN có số MIN khác nhau, bác giúp em với nhé!

Phuocam · 5/6/22

vanlinh105 đã viết:
Đúng cái em đang cần rồi bác ạ Nhưng em đang cần thêm điều kiện nữa là mỗi CN có số MIN khác nhau, bác giúp em với nhé!

Bài gốc chỉ có 1 Min, tới bài này lên 8 Min. Công viết code trước đổ sông đổ biển hết rồi!

Hahaha ...

.

vanlinh105 · 5/6/22

Phuocam đã viết:
Bài gốc chỉ có 1 Min, tới bài này lên 8 Min. Công viết code trước đổ sông đổ biển hết rồi!

Hahaha ...

.

Không bác ơi, em dùng cho nhiều bảng nên code trên là chuẩn ý của em rồi. Giờ em cần giúp đỡ thêm thôi ạ

HieuCD · 5/6/22

vanlinh105 đã viết:
Đúng cái em đang cần rồi bác ạ Nhưng em đang cần thêm điều kiện nữa là mỗi CN có số MIN khác nhau, bác giúp em với nhé!

Chỉnh lại . . .

Mã:

Sub XYZ()
  Dim arr(), res(), sRow&, sCol&, dC&, i&, j&, k&, c, jC&, iMin#, sl#
 
  arr = Range("A1", Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Value
  sRow = UBound(arr): sCol = UBound(arr, 2) / 2 + 1: dC = sCol - 2
  ReDim res(1 To sRow * dC, 1 To 4)
  For i = 2 To sRow
    For j = 3 To sCol
      iMin = arr(i, j + dC)
      Do While arr(i, j) < iMin
        sl = 0
        If arr(i, 2) = 0 Then
          For c = 3 To sCol
            If arr(i, c) > arr(i, c + dC) Then
              If sl < arr(i, c) Then
                jC = c
                sl = arr(i, c)
              End If
            End If
          Next c
          sl = sl - arr(i, jC + dC)
        Else
          jC = 2
          sl = arr(i, 2)
        End If
        If sl <= 0 Then Exit Do
        k = k + 1
        res(k, 1) = arr(i, 1)
        res(k, 2) = arr(1, jC)
        res(k, 3) = arr(1, j)
        If sl >= (iMin - arr(i, j)) Then
          arr(i, jC) = arr(i, jC) - (iMin - arr(i, j))
          res(k, 4) = iMin - arr(i, j)
          arr(i, j) = iMin
        Else
          arr(i, jC) = arr(i, jC) - sl
          arr(i, j) = arr(i, j) + sl
          res(k, 4) = sl
        End If
      Loop
    Next j
  Next i
  i = Range("T99999").End(xlUp).Row
  If i > 1 Then Range("T2:W" & i).ClearContents
  If k Then
    Range("T2").Resize(k, 4) = res
    Range("A13").Resize(sRow, sCol) = arr
  End If
End Sub

VetMini · 5/6/22

Phuocam đã viết:
Bài gốc chỉ có 1 Min, tới bài này lên 8 Min. Công viết code trước đổ sông đổ biển hết rồi!

Hahaha ...

.

Nếu viết cô lập Min miếc gì đó từ đầu thì chỉ cần đổi sub thành nhận tham số min.
Và viết thêm một sub mẹ gọi 8 cái mins. (hay trăm ngàn cái mins gì đó)

vanlinh105 · 6/6/22

HieuCD đã viết:

Chỉnh lại . . .

Mã:

Sub XYZ()
  Dim arr(), res(), sRow&, sCol&, dC&, i&, j&, k&, c, jC&, iMin#, sl#
 
  arr = Range("A1", Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Value
  sRow = UBound(arr): sCol = UBound(arr, 2) / 2 + 1: dC = sCol - 2
  ReDim res(1 To sRow * dC, 1 To 4)
  For i = 2 To sRow
    For j = 3 To sCol
      iMin = arr(i, j + dC)
      Do While arr(i, j) < iMin
        sl = 0
        If arr(i, 2) = 0 Then
          For c = 3 To sCol
            If arr(i, c) > arr(i, c + dC) Then
              If sl < arr(i, c) Then
                jC = c
                sl = arr(i, c)
              End If
            End If
          Next c
          sl = sl - arr(i, jC + dC)
        Else
          jC = 2
          sl = arr(i, 2)
        End If
        If sl <= 0 Then Exit Do
        k = k + 1
        res(k, 1) = arr(i, 1)
        res(k, 2) = arr(1, jC)
        res(k, 3) = arr(1, j)
        If sl >= (iMin - arr(i, j)) Then
          arr(i, jC) = arr(i, jC) - (iMin - arr(i, j))
          res(k, 4) = iMin - arr(i, j)
          arr(i, j) = iMin
        Else
          arr(i, jC) = arr(i, jC) - sl
          arr(i, j) = arr(i, j) + sl
          res(k, 4) = sl
        End If
      Loop
    Next j
  Next i
  i = Range("T99999").End(xlUp).Row
  If i > 1 Then Range("T2:W" & i).ClearContents
  If k Then
    Range("T2").Resize(k, 4) = res
    Range("A13").Resize(sRow, sCol) = arr
  End If
End Sub

Em cảm ơn bác nhiều ạ

Together11 · 21/6/22

HieuCD đã viết:

Chỉnh lại . . .

Mã:

Sub XYZ()
  Dim arr(), res(), sRow&, sCol&, dC&, i&, j&, k&, c, jC&, iMin#, sl#
 
  arr = Range("A1", Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Value
  sRow = UBound(arr): sCol = UBound(arr, 2) / 2 + 1: dC = sCol - 2
  ReDim res(1 To sRow * dC, 1 To 4)
  For i = 2 To sRow
    For j = 3 To sCol
      iMin = arr(i, j + dC)
      Do While arr(i, j) < iMin
        sl = 0
        If arr(i, 2) = 0 Then
          For c = 3 To sCol
            If arr(i, c) > arr(i, c + dC) Then
              If sl < arr(i, c) Then
                jC = c
                sl = arr(i, c)
              End If
            End If
          Next c
          sl = sl - arr(i, jC + dC)
        Else
          jC = 2
          sl = arr(i, 2)
        End If
        If sl <= 0 Then Exit Do
        k = k + 1
        res(k, 1) = arr(i, 1)
        res(k, 2) = arr(1, jC)
        res(k, 3) = arr(1, j)
        If sl >= (iMin - arr(i, j)) Then
          arr(i, jC) = arr(i, jC) - (iMin - arr(i, j))
          res(k, 4) = iMin - arr(i, j)
          arr(i, j) = iMin
        Else
          arr(i, jC) = arr(i, jC) - sl
          arr(i, j) = arr(i, j) + sl
          res(k, 4) = sl
        End If
      Loop
    Next j
  Next i
  i = Range("T99999").End(xlUp).Row
  If i > 1 Then Range("T2:W" & i).ClearContents
  If k Then
    Range("T2").Resize(k, 4) = res
    Range("A13").Resize(sRow, sCol) = arr
  End If
End Sub

Bạn ơi mình có bài toán như thế này, mong được bạn hỗ trợ viết code vba ạ
Yêu cầu :
1. Nhặt hàng theo thứ tự ưu tiên từ KHO DỰ TRỮ và từ 1 dãy cửa hàng trả về cho cửa hàng ở cột cuối ( Ở đây mình đang ví dụ nhặt từ kho dự trữ và 10 CH )
2. Số lượng nhặt từ kho dự trữ thì nhặt hết, số lượng nhặt từ các CH, nhặt theo thứ tự tồn các CH từ nhiều nhất đến ít nhất, ko quá 1 tỷ lệ % tồn mà mình đặt sẵn ở 1 ô nào đó ( ví dụ : ô P1)
3. Sau khi nhặt trả sang bảng chi tiết là chuyển mã nào từ đâu đến CH nhận và số lượng chuyển.

		TỒN											Tỷ lệ nhặt	0.3
MÃ HÀNG	DỰ TRỮ	CH1	CH2	CH3	CH4	CH5	CH6	CH7	CH8	CH9	CH10	CH NHẬN
MÃ HÀNG 1	52	80	69	77	63	67	63	73	84	72	82	558
MÃ HÀNG 2	69	82	81	59	100	62	59	99	66	61	54	561
MÃ HÀNG 3	87	79	50	83	61	53	56	93	93	85	84	584
MÃ HÀNG 4	51	66	75	80	60	51	83	85	65	69	79	508
MÃ HÀNG 5	78	73	59	50	50	64	69	78	93	78	50	583
MÃ HÀNG 6	71	90	59	54	54	59	72	53	99	73	100	600
MÃ HÀNG 7	90	91	71	77	70	68	65	57	70	75	80	576
MÃ HÀNG 8	86	94	100	73	81	98	63	90	98	75	73	571
MÃ HÀNG 9	93	78	50	71	92	96	70	77	84	57	100	564
MÃ HÀNG 10	72	69	58	97	55	89	63	98	84	78	69	531

HUONGHCKT · 21/6/22

Together11 đã viết:
Bạn ơi mình có bài toán như thế này, mong được bạn hỗ trợ viết code vba ạ
Yêu cầu :
1. Nhặt hàng theo thứ tự ưu tiên từ KHO DỰ TRỮ và từ 1 dãy cửa hàng trả về cho cửa hàng ở cột cuối ( Ở đây mình đang ví dụ nhặt từ kho dự trữ và 10 CH )
2. Số lượng nhặt từ kho dự trữ thì nhặt hết, số lượng nhặt từ các CH, nhặt theo thứ tự tồn các CH từ nhiều nhất đến ít nhất, ko quá 1 tỷ lệ % tồn mà mình đặt sẵn ở 1 ô nào đó ( ví dụ : ô P1)
3. Sau khi nhặt trả sang bảng chi tiết là chuyển mã nào từ đâu đến CH nhận và số lượng chuyển.

TỒN Tỷ lệ nhặt
0.3
MÃ HÀNG DỰ TRỮ CH1 CH2 CH3 CH4 CH5 CH6 CH7 CH8 CH9 CH10 CH NHẬN
MÃ HÀNG 1
52
80
69
77
63
67
63
73
84
72
82
558
MÃ HÀNG 2
69
82
81
59
100
62
59
99
66
61
54
561
MÃ HÀNG 3
87
79
50
83
61
53
56
93
93
85
84
584
MÃ HÀNG 4
51
66
75
80
60
51
83
85
65
69
79
508
MÃ HÀNG 5
78
73
59
50
50
64
69
78
93
78
50
583
MÃ HÀNG 6
71
90
59
54
54
59
72
53
99
73
100
600
MÃ HÀNG 7
90
91
71
77
70
68
65
57
70
75
80
576
MÃ HÀNG 8
86
94
100
73
81
98
63
90
98
75
73
571
MÃ HÀNG 9
93
78
50
71
92
96
70
77
84
57
100
564
MÃ HÀNG 10
72
69
58
97
55
89
63
98
84
78
69
531

Thử xem, hy vọng có tác dụng nào đó.

Mã:

Option Explicit

Sub NhatHang()
Dim i&, j&, Lr&, K
Dim Arr(), Res()
Dim Ws As Worksheet
Set Ws = Sheet1
K = Ws.[L1]
Lr = Ws.Cells(Rows.Count, 1).End(3).Row
Arr = Ws.Range("A3:L" & Lr).Value
ReDim Res(1 To UBound(Arr), 1 To 2)
For i = 1 To UBound(Arr)
    Res(i, 1) = Arr(i, 1)
    Res(i, 2) = Arr(i, 2)
    For j = 3 To UBound(Arr, 2)
        Res(i, 2) = Res(i, 2) + Arr(i, j) * K
    Next j
Next i
Sheets("ChiTiet").Range("A2").Resize(i - 1, 2) = Res

End Sub

Ô tỷ lệ nhặt là ô L1/Sh ChiTiet
Nhấn vào nút Run để xem kết quả.

Together11 · 21/6/22

HUONGHCKT đã viết:
Thử xem, hy vọng có tác dụng nào đó.

Mã:

Option Explicit Sub NhatHang() Dim i&, j&, Lr&, K Dim Arr(), Res() Dim Ws As Worksheet Set Ws = Sheet1 K = Ws.[L1] Lr = Ws.Cells(Rows.Count, 1).End(3).Row Arr = Ws.Range("A3:L" & Lr).Value ReDim Res(1 To UBound(Arr), 1 To 2) For i = 1 To UBound(Arr) Res(i, 1) = Arr(i, 1) Res(i, 2) = Arr(i, 2) For j = 3 To UBound(Arr, 2) Res(i, 2) = Res(i, 2) + Arr(i, j) * K Next j Next i Sheets("ChiTiet").Range("A2").Resize(i - 1, 2) = Res End Sub

Ô tỷ lệ nhặt là ô L1/Sh ChiTiet
Nhấn vào nút Run để xem kết quả.

Rất cảm ơn bạn ạ, bạn có thể viết thêm giúp mình chi tiết ra 1 bảng là nhặt hàng từ CH Nào, SL bao nhiêu đến CH đích và số lượng nhặt hàng ko đc vượt quá số lượng hàng mà CH nhận cần ạ, nếu 10 CH đó lấy ko đủ thì thêm CH khác vào. Nếu nhặt chưa hết 10 CH đã đủ thì dừng luôn ko nhặt nữa.
Bảng trả ra gồm 3 cột : Mã hàng, CH chuyển, SL chuyển ạ.

HUONGHCKT · 21/6/22

Together11 đã viết:
Rất cảm ơn bạn ạ, bạn có thể viết thêm giúp mình chi tiết ra 1 bảng là nhặt hàng từ CH Nào, SL bao nhiêu đến CH đích và số lượng nhặt hàng ko đc vượt quá số lượng hàng mà CH nhận cần ạ, nếu 10 CH đó lấy ko đủ thì thêm CH khác vào. Nếu nhặt chưa hết 10 CH đã đủ thì dừng luôn ko nhặt nữa.
Bảng trả ra gồm 3 cột : Mã hàng, CH chuyển, SL chuyển ạ.

Thay code cũ bằng:

Mã:

Option Explicit

Sub NhatHang()
Dim i&, j&, Lr&, K, t&, n&
Dim Arr(), Res()
Dim Ws As Worksheet
Set Ws = Sheet1
K = Sheets("ChiTiet").[D1]
Lr = Ws.Cells(Rows.Count, 1).End(3).Row
Arr = Ws.Range("A2:L" & Lr).Value
ReDim Res(1 To UBound(Arr) * UBound(Arr, 2), 1 To 3)
For i = 2 To UBound(Arr)
    For j = 2 To UBound(Arr, 2)
        t = t + 1
        Res(t, 1) = Arr(i, 1)
        Res(t, 2) = Arr(1, j)
        Res(t, 3) = Arr(i, 2)
    If j > 2 Then Res(t, 3) = Arr(i, j) * K
    Next j
Next i
Sheets("ChiTiet").Range("A3").Resize(UBound(Arr) * UBound(Arr, 2), 3) = Res
MsgBox "Done"
End Sub

Together11 · 21/6/22

HUONGHCKT đã viết:

Thay code cũ bằng:

Mã:

Option Explicit

Sub NhatHang()
Dim i&, j&, Lr&, K, t&, n&
Dim Arr(), Res()
Dim Ws As Worksheet
Set Ws = Sheet1
K = Sheets("ChiTiet").[D1]
Lr = Ws.Cells(Rows.Count, 1).End(3).Row
Arr = Ws.Range("A2:L" & Lr).Value
ReDim Res(1 To UBound(Arr) * UBound(Arr, 2), 1 To 3)
For i = 2 To UBound(Arr)
    For j = 2 To UBound(Arr, 2)
        t = t + 1
        Res(t, 1) = Arr(i, 1)
        Res(t, 2) = Arr(1, j)
        Res(t, 3) = Arr(i, 2)
    If j > 2 Then Res(t, 3) = Arr(i, j) * K
    Next j
Next i
Sheets("ChiTiet").Range("A3").Resize(UBound(Arr) * UBound(Arr, 2), 3) = Res
MsgBox "Done"
End Sub

Cảm ơn bạn rất nhiều ạ.

Together11 · 21/6/22

HUONGHCKT đã viết:

Thay code cũ bằng:

Mã:

Option Explicit

Sub NhatHang()
Dim i&, j&, Lr&, K, t&, n&
Dim Arr(), Res()
Dim Ws As Worksheet
Set Ws = Sheet1
K = Sheets("ChiTiet").[D1]
Lr = Ws.Cells(Rows.Count, 1).End(3).Row
Arr = Ws.Range("A2:L" & Lr).Value
ReDim Res(1 To UBound(Arr) * UBound(Arr, 2), 1 To 3)
For i = 2 To UBound(Arr)
    For j = 2 To UBound(Arr, 2)
        t = t + 1
        Res(t, 1) = Arr(i, 1)
        Res(t, 2) = Arr(1, j)
        Res(t, 3) = Arr(i, 2)
    If j > 2 Then Res(t, 3) = Arr(i, j) * K
    Next j
Next i
Sheets("ChiTiet").Range("A3").Resize(UBound(Arr) * UBound(Arr, 2), 3) = Res
MsgBox "Done"
End Sub

Bạn ơi nếu số lượng CH ko phải chỉ là 10 mà còn tăng lên hoặc giảm đi thì mình lấy biến cột cuối gán vào ntn Và hiện tại mình thử chạy CODE vẫn bị nhặt quá số lượng mà CH nhận cần ạ.
Mong bạn hỗ trợ nốt mình với nhé, cảm ơn bạn nhiều ạ.

bebo021999 · 21/6/22

Làm đại:

PHP:

Option Explicit
Sub collection()
Dim lr&, lc&, i&, j&, k&, sG&, sC&, max&, sum&
Dim rng, rng2, arr(), ch As String
Worksheets("Sheet1").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
rng = Range("B2", Cells(lr, lc)).Value
rng2 = Range("B2", Cells(lr, lc)).Value
Worksheets("Sheet2").Range("A2:M100").ClearContents
ReDim arr(1 To lr - 1, 1 To lc - 1)
    For i = 2 To lr - 1
        max = 0
        For j = 2 To lc - 3
            For k = j + 1 To lc - 2
                If rng(i, j) < rng(i, k) Then
                    max = rng(i, k): ch = rng(1, k)
                    rng(i, k) = rng(i, j): rng(1, k) = rng(1, j)
                    rng(i, j) = max: rng(1, j) = ch
                End If
            Next
        Next
    Next
    With WorksheetFunction
        For i = 2 To lr - 1
            sG = .Min(rng(i, 1), rng(i, lc - 1)): rng(i, 1) = sG
            sC = rng(i, lc - 1) - sG
            sum = sG
            For j = 2 To lc - 2
                sG = .Min(Round(rng(i, j) * (1 - Range("M1")), 0), sC): rng(i, j) = sG
                sC = sC - sG
                sum = sum + sG
            Next
            rng(i, lc - 1) = sum
            For j = 2 To lc - 2
                For k = 2 To lc - 2
                    If rng2(1, j) = rng(1, k) Then
                        max = rng(i, j): ch = rng(1, j)
                        rng(i, j) = rng(i, k): rng(1, j) = rng(1, k)
                        rng(i, k) = max: rng(1, k) = ch
                    End If
                Next
            Next
        Next
    End With
Worksheets("Sheet2").Activate
Range("B2").Resize(i - 1, j).Value = rng
Range("A2").Resize(i - 1, 1).Value = Worksheets("Sheet1").Range("A2:A" & lr).Value
End Sub

Together11 · 21/6/22

bebo021999 đã viết:

Làm đại:

PHP:

Option Explicit
Sub collection()
Dim lr&, lc&, i&, j&, k&, sG&, sC&, max&, sum&
Dim rng, rng2, arr(), ch As String
Worksheets("Sheet1").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
rng = Range("B2", Cells(lr, lc)).Value
rng2 = Range("B2", Cells(lr, lc)).Value
Worksheets("Sheet2").Range("A2:M100").ClearContents
ReDim arr(1 To lr - 1, 1 To lc - 1)
    For i = 2 To lr - 1
        max = 0
        For j = 2 To lc - 3
            For k = j + 1 To lc - 2
                If rng(i, j) < rng(i, k) Then
                    max = rng(i, k): ch = rng(1, k)
                    rng(i, k) = rng(i, j): rng(1, k) = rng(1, j)
                    rng(i, j) = max: rng(1, j) = ch
                End If
            Next
        Next
    Next
    With WorksheetFunction
        For i = 2 To lr - 1
            sG = .Min(rng(i, 1), rng(i, lc - 1)): rng(i, 1) = sG
            sC = rng(i, lc - 1) - sG
            sum = sG
            For j = 2 To lc - 2
                sG = .Min(Round(rng(i, j) * (1 - Range("M1")), 0), sC): rng(i, j) = sG
                sC = sC - sG
                sum = sum + sG
            Next
            rng(i, lc - 1) = sum
            For j = 2 To lc - 2
                For k = 2 To lc - 2
                    If rng2(1, j) = rng(1, k) Then
                        max = rng(i, j): ch = rng(1, j)
                        rng(i, j) = rng(i, k): rng(1, j) = rng(1, k)
                        rng(i, k) = max: rng(1, k) = ch
                    End If
                Next
            Next
        Next
    End With
Worksheets("Sheet2").Activate
Range("B2").Resize(i - 1, j).Value = rng
Range("A2").Resize(i - 1, 1).Value = Worksheets("Sheet1").Range("A2:A" & lr).Value
End Sub

Xin cảm ơn bác ạ

Together11 · 21/6/22

bebo021999 đã viết:

Làm đại:

PHP:

Option Explicit
Sub collection()
Dim lr&, lc&, i&, j&, k&, sG&, sC&, max&, sum&
Dim rng, rng2, arr(), ch As String
Worksheets("Sheet1").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
rng = Range("B2", Cells(lr, lc)).Value
rng2 = Range("B2", Cells(lr, lc)).Value
Worksheets("Sheet2").Range("A2:M100").ClearContents
ReDim arr(1 To lr - 1, 1 To lc - 1)
    For i = 2 To lr - 1
        max = 0
        For j = 2 To lc - 3
            For k = j + 1 To lc - 2
                If rng(i, j) < rng(i, k) Then
                    max = rng(i, k): ch = rng(1, k)
                    rng(i, k) = rng(i, j): rng(1, k) = rng(1, j)
                    rng(i, j) = max: rng(1, j) = ch
                End If
            Next
        Next
    Next
    With WorksheetFunction
        For i = 2 To lr - 1
            sG = .Min(rng(i, 1), rng(i, lc - 1)): rng(i, 1) = sG
            sC = rng(i, lc - 1) - sG
            sum = sG
            For j = 2 To lc - 2
                sG = .Min(Round(rng(i, j) * (1 - Range("M1")), 0), sC): rng(i, j) = sG
                sC = sC - sG
                sum = sum + sG
            Next
            rng(i, lc - 1) = sum
            For j = 2 To lc - 2
                For k = 2 To lc - 2
                    If rng2(1, j) = rng(1, k) Then
                        max = rng(i, j): ch = rng(1, j)
                        rng(i, j) = rng(i, k): rng(1, j) = rng(1, k)
                        rng(i, k) = max: rng(1, k) = ch
                    End If
                Next
            Next
        Next
    End With
Worksheets("Sheet2").Activate
Range("B2").Resize(i - 1, j).Value = rng
Range("A2").Resize(i - 1, 1).Value = Worksheets("Sheet1").Range("A2:A" & lr).Value
End Sub

Bác ơi bác sửa giúp em :
1. Nhặt hàng từ CH tồn nhiều nhất đến CH tồn ít nhất
2. Tại các CH thì Nhân với tỷ lệ đặt tại 1 ô bất kì ạ, nếu sau khi nhân theo tỷ lệ mà thiếu thì cứ để số lượng tối đa mà nhặt được, em sẽ thêm CH vào để nhặt tiếp ạ.
( Em vẫn chưa hiểu bác đang đặt code như thế nào nhưng có CH chỉ tồn 82 nhưng lấy tận 100 )
3. Trả về 1 bảng nữa để biết : Mã Hàng A Chuyển từ CH1 Số lượng chuyển xx
Em cảm ơn bác ạ

Together11 · 21/6/22

Em cần trả về 2 cái bảng như dạng bác gì ở trên làm đó ạ.
Bảng ở dưới bảng gốc, số lượng còn lại ở mỗi CH sau khi chuyển cho CH nhận
Bảng bên cạnh hiện nội dung như ví dụ trong ảnh này ạ.

CHAOQUAY · 22/6/22

Together11 đã viết:
Em cần trả về 2 cái bảng như dạng bác gì ở trên làm đó ạ.
Bảng ở dưới bảng gốc, số lượng còn lại ở mỗi CH sau khi chuyển cho CH nhận
Bảng bên cạnh hiện nội dung như ví dụ trong ảnh này ạ.

View attachment 277715

Chèn thêm 1 sheet, đặt tên là "Chitiet", chạy code dưới đây.
Bảng gốc bên trên, bảng dưới là số lượng còn lại. Riêng cột cuối bảng dưới là số đã chuyển

Mã:

Option Explicit

Sub phanHang()
Dim Nguon
Dim Kq
Dim Tl
Dim TongN
Dim TongX
Dim Vt, Sl
Dim rws, cls
Dim i, j, k, x, z, t

Nguon = Sheet1.Range("A2", Sheet1.Range("A2").End(xlToRight).End(xlDown))
rws = UBound(Nguon)
cls = UBound(Nguon, 2)

Sheets("Chitiet").UsedRange.Clear
Sheets("Chitiet").Range("A3").Resize(rws, cls) = Nguon

Tl = Sheet1.Range("L1")

Kq = Nguon
For i = 2 To rws
    For j = 3 To cls
        Kq(i, j) = Empty
    Next j
Next i

For i = 2 To rws
    For j = 3 To cls - 1
        k = Nguon(i, j) * 100 + j
        Nguon(i, j) = k
    Next j
    
    For j = 3 To cls - 2
        For k = j + 1 To cls - 1
            If Nguon(i, k) > Nguon(i, j) Then
                t = Nguon(i, k)
                Nguon(i, k) = Nguon(i, j)
                Nguon(i, j) = t
            End If
        Next k
    Next j
    
    TongN = Nguon(i, cls) - Nguon(i, 2)
    Kq(i, cls) = Kq(i, 2)
    Kq(i, 2) = Empty
    If TongN > 0 Then
        TongX = 0
        For j = 3 To cls - 1
            Vt = Nguon(i, j) Mod 100
            Sl = Nguon(i, j) \ 100
            
            x = Int(Tl * Sl)
            If TongX + x < TongN Then
                z = x
            Else
                z = TongN - TongX
            End If
            
            If z Then
                'Kq(i, Vt) = z
                Kq(i, Vt) = Sl - z
                TongX = TongX + z
            End If
        Next j
        
        Kq(i, cls) = Kq(i, cls) + TongX
    End If
Next i

With Sheets("Chitiet")
    .Range("A3").End(xlDown).Offset(2).Resize(rws, cls) = Kq
    .UsedRange.Columns.AutoFit
End With
End Sub

Together11 · 22/6/22

CHAOQUAY đã viết:

Chèn thêm 1 sheet, đặt tên là "Chitiet", chạy code dưới đây.
Bảng gốc bên trên, bảng dưới là số lượng còn lại. Riêng cột cuối bảng dưới là số đã chuyển

Mã:

Option Explicit

Sub phanHang()
Dim Nguon
Dim Kq
Dim Tl
Dim TongN
Dim TongX
Dim Vt, Sl
Dim rws, cls
Dim i, j, k, x, z, t

Nguon = Sheet1.Range("A2", Sheet1.Range("A2").End(xlToRight).End(xlDown))
rws = UBound(Nguon)
cls = UBound(Nguon, 2)

Sheets("Chitiet").UsedRange.Clear
Sheets("Chitiet").Range("A3").Resize(rws, cls) = Nguon

Tl = Sheet1.Range("L1")

Kq = Nguon
For i = 2 To rws
    For j = 3 To cls
        Kq(i, j) = Empty
    Next j
Next i

For i = 2 To rws
    For j = 3 To cls - 1
        k = Nguon(i, j) * 100 + j
        Nguon(i, j) = k
    Next j
   
    For j = 3 To cls - 2
        For k = j + 1 To cls - 1
            If Nguon(i, k) > Nguon(i, j) Then
                t = Nguon(i, k)
                Nguon(i, k) = Nguon(i, j)
                Nguon(i, j) = t
            End If
        Next k
    Next j
   
    TongN = Nguon(i, cls) - Nguon(i, 2)
    Kq(i, cls) = Kq(i, 2)
    Kq(i, 2) = Empty
    If TongN > 0 Then
        TongX = 0
        For j = 3 To cls - 1
            Vt = Nguon(i, j) Mod 100
            Sl = Nguon(i, j) \ 100
           
            x = Int(Tl * Sl)
            If TongX + x < TongN Then
                z = x
            Else
                z = TongN - TongX
            End If
           
            If z Then
                'Kq(i, Vt) = z
                Kq(i, Vt) = Sl - z
                TongX = TongX + z
            End If
        Next j
       
        Kq(i, cls) = Kq(i, cls) + TongX
    End If
Next i

With Sheets("Chitiet")
    .Range("A3").End(xlDown).Offset(2).Resize(rws, cls) = Kq
    .UsedRange.Columns.AutoFit
End With
End Sub

Vô cùng cảm ơn bác ạ, Mong bác bớt chút time thêm giúp em cái phần như ảnh là Done ạ.

CHAOQUAY · 22/6/22

Together11 đã viết:
View attachment 277721
Vô cùng cảm ơn bác ạ, Mong bác bớt chút time thêm giúp em cái phần như ảnh là Done ạ.

Chạy macro "phanHang" trong file đính kèm

---
Luu ý là số cửa hàng của 1 mã hàng <100

HUONGHCKT · 22/6/22

Together11 đã viết:
Bạn ơi nếu số lượng CH ko phải chỉ là 10 mà còn tăng lên hoặc giảm đi thì mình lấy biến cột cuối gán vào ntn Và hiện tại mình thử chạy CODE vẫn bị nhặt quá số lượng mà CH nhận cần ạ.
Mong bạn hỗ trợ nốt mình với nhé, cảm ơn bạn nhiều ạ.

Tốt nhất là bạn đưa file lên. Chứ chỉ nói không với nhìn ảnh thì không có thời gian để luận và đình hình xem nó là cái gì? Do vậy có code được cũng chỉ là đoán mò===> đúng sai không nói trước được (vì có hiểu ý và có dữ liệu đâu để thử).
Đoán Mò ý bạn là Trong một bảng có nhiều cửa hàng(CH) nhưng có mã bạn muốn nhặt đến CH cuối cùng có mã bạn lại chỉ muốn nhặt đến CHn nào đó. Nếu đúng vậy phải code lại.
Nếu nhìn như ảnh bài thì có lẽ là sửa lại code ở bài #17
Từ:

Mã:

For j = 2 To UBound(Arr, 2)

thành

Mã:

For j = 2 To UBound(Arr, 2)-1

Hy vọng đúng

Together11 · 22/6/22

HUONGHCKT đã viết:
Tốt nhất là bạn đưa file lên. Chứ chỉ nói không với nhìn ảnh thì không có thời gian để luận và đình hình xem nó là cái gì? Do vậy có code được cũng chỉ là đoán mò===> đúng sai không nói trước được (vì có hiểu ý và có dữ liệu đâu để thử).
Đoán Mò ý bạn là Trong một bảng có nhiều cửa hàng(CH) nhưng có mã bạn muốn nhặt đến CH cuối cùng có mã bạn lại chỉ muốn nhặt đến CHn nào đó. Nếu đúng vậy phải code lại.
Nếu nhìn như ảnh bài thì có lẽ là sửa lại code ở bài #17
Từ:

Mã:

For j = 2 To UBound(Arr, 2)

thành

Mã:

For j = 2 To UBound(Arr, 2)-1

Hy vọng đúng

Dạ file mình có đưa lên rồi ạ. Cảm ơn bạn nhé. Sau mình xin rút kinh nghiệm ạ

Together11 · 22/6/22

CHAOQUAY đã viết:
Chạy macro "phanHang" trong file đính kèm

---
Luu ý là số cửa hàng của 1 mã hàng <100

File chạy ok rồi. Cảm ơn bác rất nhiều ạ

Together11 · 18/11/22

Bác ơi, cảm ơn lần trước bác đã hỗ trợ
Hôm nay có vấn đề này của em mong nhận được sự hỗ trợ từ bác và các anh chị em trong diễn đàn GPE ạ.
Em có bài toán chia hàng tương tự như bài của bác chủ topic nhưng khác đôi chút ở phần quy luật, nhờ bác viết giúp em đoạn code VBA chạy phần này với ạ.
Em gửi file và ảnh :

CHAOQUAY đã viết:
Chạy macro "phanHang" trong file đính kèm

---
Luu ý là số cửa hàng của 1 mã hàng <100

Chia số lượng theo điều kiện (1 người xem)

Người dùng đang xem chủ đề này

Thành viên chính thức

File đính kèm

Thành viên gạo cội

Thành viên mới

Thành viên chính thức

Thành viên gạo cội

Đang đi tìm hòn đá

Chuyên gia GPE

File đính kèm

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên chính thức

Chuyên gia GPE

Đang đi tìm hòn đá

Thành viên chính thức

Thành viên mới

File đính kèm

Zalo 0986997214

File đính kèm

Thành viên mới

Zalo 0986997214

Thành viên mới

Thành viên mới

File đính kèm

Thành viên gạo cội

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên gắn bó

Thành viên mới

Thành viên gắn bó

File đính kèm

Zalo 0986997214

Thành viên mới

Thành viên mới

Thành viên mới

File đính kèm

Thời gian đếm ngược.