Chia số lượng theo điều kiện

Liên hệ QC
V

vanlinh105

Thành viên chính thức
Tham gia
30/3/16
Bài viết
56
Được thích
4
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.
screenshot_1654325331.png
 

File đính kèm

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
Nhấp chuột vào đây để mở rộng...
Biết dùng VBA không bạn.
 
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.
Nhấp chuột vào đây để mở rộng...
Sản phẩmCN0CN1CN2CN3CN4CN5CN6CN7CN8MIN
Sản phẩm A010119181716151410
Kết quả 1:0101010181716151410
Kết quả 2:0101015151516151410

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?

.
 
snow25 đã viết:
Biết dùng VBA không bạn.
Nhấp chuột vào đây để mở rộng...
Em không bác ơi, em chỉ dùng công thức thôi.
Bài đã được tự động gộp:

Phuocam đã viết:
Sản phẩmCN0CN1CN2CN3CN4CN5CN6CN7CN8MIN
Sản phẩm A010119181716151410
Kết quả 1:0101010181716151410
Kết quả 2:0101015151516151410

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?

.
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
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:


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.
Nhấp chuột vào đây để mở rộng...
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
 
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í:
...
Nhấp chuột vào đây để mở rộng...
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).
 
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.
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

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
Nhấp chuột vào đây để mở rộng...
Đú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é!
 

File đính kèm

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é!
Nhấp chuột vào đây để mở rộng...

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 đã 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é!
Nhấp chuột vào đây để mở rộng...
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
 
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 ...

.
Nhấp chuột vào đây để mở rộng...
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ì đó)
 
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
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác nhiều ạ :)
 
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
Nhấp chuột vào đây để mở rộng...
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ỒNTỷ lệ nhặt
0.3​
MÃ HÀNGDỰ TRỮCH1CH2CH3CH4CH5CH6CH7CH8CH9CH10CH 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​
 

File đính kèm

Lần chỉnh sửa cuối:
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ỒNTỷ lệ nhặt
0.3​
MÃ HÀNGDỰ TRỮCH1CH2CH3CH4CH5CH6CH7CH8CH9CH10CH 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​
Nhấp chuột vào đây để mở rộng...
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ả.
 

File đính kèm

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ả.
Nhấp chuột vào đây để mở rộng...
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 ạ.
 
Lần chỉnh sửa cuối:
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 ạ.
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn rất nhiều ạ.
 
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
Nhấp chuột vào đây để mở rộng...
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 ạ.
 

File đính kèm

  • 1655793264487.png
    1655793264487.png
    9.9 KB · Đọc: 9
Lần chỉnh sửa cuối:
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ạ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 Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
307
Đọc
22K
kunkoi9390
K
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
6
Đọc
2K
tranhungdao12a3
T
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
4
Đọc
150
cuongtri
C
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
45
Đọc
14K
ngocthu90
ngocthu90
Uyên dương Hoya
Lỗi định dạng font chữ trong excel
Trả lời
3
Đọc
122
ptm0412
ptm0412
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
1
Đọc
68
vietduc147258
V
T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
12
Đọc
444
VetMini
V
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
8
Đọc
663
nguyendang95
N
ntnguyentam1907
Lấy bảng dữ liệu chứng khoán về excel
2
Trả lời
22
Đọc
3K
nguyendang95
N
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
5
Đọc
772
hoangtuan.net
hoangtuan.net
HONGVY91
Đếm số lượng 2 cột và đếm không trùng
Trả lời
2
Đọc
137
hoangtuaotrang_hp_vn
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
3
Đọc
197
hanhlx88
hanhlx88
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
73
Đọc
10K
HeSanbi
HeSanbi
L
Folder chứa chương trình bị khóa bởi Lock folder
2
Trả lời
28
Đọc
25K
qthangvphaui
Q
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
4
Đọc
160
phambahoang
P
N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
85
HUONGHCKT
H
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
208
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
257
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom