Chia tiến độ bằng VBA (1 người xem)

[vulunktheky]

Chào anh chị và các bạn,
Nhờ các bạn giúp đỡ mình chia tiến độ bằng VBA, vì bình thường mình làm thao tác thủ công rất lâu và dễ bị sai sót.
Chia tiến độ với yêu cầu như sau:
+ Nhập vào size bất kỳ (bắt buộc phải nhập tay) thì sẽ trả về tên màu và số lượng của màu đó (Mỗi lần chia số lượng của màu không quá 24 đôi) và chia đến hết màu và số lượng của từng màu.
+ nếu màu đó được chia hết số lượng mà vẫn nhập vào số Size thì sẽ xuất hiện thông báo cảnh báo là hết số lượng.
Mình cảm ơn!

 

[vulunktheky]

Mỗi lần chạy code là mấy ngày?
Nếu nhập 4, 5 size và code sẽ tự tính theo thứ tự ưu tiên từ trái qua phải, đủ 2500 thì dừng được không?

Mỗi lần chạy code là chia cho 1 ngày á a, còn 2500 là ví dụ e đưa ra cho dễ hình dung chứ mục tiêu mỗi ngày là khác nhau. Bài #14 là đúng ý e rồi nhưng vấn đề là còn những ô còn thiếu sản lượng đó nữa thôi á anh.

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

Mỗi lần chạy code là mấy ngày?
Nếu nhập 4, 5 size và code sẽ tự tính theo thứ tự ưu tiên từ trái qua phải, đủ 2500 thì dừng được không?

Nhập chỉ tối đa là 3 size, nếu cái size đó hết số lượng mà vẫn chưa đủ mục tiêu thì tiếp tục nhập size và màu vào ô kế và chạy code lại và xem sản lượng có đủ với mục tiêu không.

 

[HieuCD]

Mỗi lần chạy code là chia cho 1 ngày á a, còn 2500 là ví dụ e đưa ra cho dễ hình dung chứ mục tiêu mỗi ngày là khác nhau. Bài #14 là đúng ý e rồi nhưng vấn đề là còn những ô còn thiếu sản lượng đó nữa thôi á anh.

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

Nhập chỉ tối đa là 3 size, nếu cái size đó hết số lượng mà vẫn chưa đủ mục tiêu thì tiếp tục nhập size và màu vào ô kế và chạy code lại và xem sản lượng có đủ với mục tiêu không.

Chạy code

Sub PhanBo()
  Dim sArr(), sRow, sCol
  Dim DK(), eR, eC, Size, Mau As String
  Dim i, j, n, m, k, Sl, tmp, dtBln As Boolean
  Const DKaddress = "A1:AE124" 'Dia chi du lieu Sheet TH2
  Const dR = 7 'Khoang cach ket qua
  Const dC = 3 'Nhom Size
  Const iMax = 24 'So luong toi da
  
  With Sheets("JR size nho ")
    eR = .Range("C" & Rows.Count).End(xlUp).Row
    If eR < 3 Then MsgBox ("Khong co Du Lieu Size"): Exit Sub
    sArr = .Range("C2:Z" & eR).Value 'Bang Size
    sRow = UBound(sArr):    sCol = UBound(sArr, 2)
  End With
  
  With Sheets("TH2")
    DK = .Range(DKaddress).Value 'Bang Ket qua
    eR = UBound(DK, 1) 'dond Cuoi
    eC = UBound(DK, 2) 'Cot cuoi
  End With
  
  Application.ScreenUpdating = False
  For m = 1 To dC
    For i = 2 To eR Step dR
      For j = 2 To eC
        If Len(DK(i, j)) > 0 And Len(DK(i + 1, j)) > 0 And Len(DK(i + 3, j)) = 0 Then
          Size = DK(i, j): Mau = DK(i + 1, j)
          For k = 2 To sCol
            If sArr(1, k) = Size Then
              For n = 2 To sRow
                If sArr(n, 1) = Mau Then
                  Sl = sArr(n, k)
                  If Sl > 0 Then
                    dtBln = True
                    Do While Sl > 0
                      If Sl > iMax Then tmp = iMax Else tmp = Sl
                      Sl = Sl - tmp
                      If j > eC Then
                        i = i + dR
                        j = j - eC + 1
                      End If
                      With Sheets("TH2")
                        If i < eR Then
                          .Cells(i, j) = Size
                          .Cells(i + 1, j) = Mau
                          .Cells(i + 3, j) = tmp
                          DK(i + 3, j) = tmp
                        End If
                      End With
                      j = j + dC
                    Loop
                    GoTo Tiep
                  End If
                End If
              Next n
            End If
          Next k
        End If
      Next j
    Next i
Tiep:
  Next m
  If dtBln = False Then MsgBox ("Khong Co Du Lieu Phu Hop")
  Application.ScreenUpdating = True
End Sub

Sub XoaKetQua()
  Dim i
  Const fR = 2 'Dòng dau Sheet TH
  Const dR = 7 'Khoang cach ket qua
  Const sC = 30 'So cuoi

  With Sheets("TH2")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then
      Application.ScreenUpdating = False
      For i = fR To eRow Step dR
        .Range("B" & i).Resize(2, sC).ClearContents
        .Range("B" & i + 3).Resize(, sC).ClearContents
      Next i
      Application.ScreenUpdating = True
    End If
  End With
End Sub

Chạy code phải theo đúng trình tự, nếu không kết quả sẽ tùm lum

 

[vulunktheky]

Chạy code

Sub PhanBo()
  Dim sArr(), sRow, sCol
  Dim DK(), eR, eC, Size, Mau As String
  Dim i, j, n, m, k, Sl, tmp, dtBln As Boolean
  Const DKaddress = "A1:AE124" 'Dia chi du lieu Sheet TH2
  Const dR = 7 'Khoang cach ket qua
  Const dC = 3 'Nhom Size
  Const iMax = 24 'So luong toi da
 
  With Sheets("JR size nho ")
    eR = .Range("C" & Rows.Count).End(xlUp).Row
    If eR < 3 Then MsgBox ("Khong co Du Lieu Size"): Exit Sub
    sArr = .Range("C2:Z" & eR).Value 'Bang Size
    sRow = UBound(sArr):    sCol = UBound(sArr, 2)
  End With
 
  With Sheets("TH2")
    DK = .Range(DKaddress).Value 'Bang Ket qua
    eR = UBound(DK, 1) 'dond Cuoi
    eC = UBound(DK, 2) 'Cot cuoi
  End With
 
  Application.ScreenUpdating = False
  For m = 1 To dC
    For i = 2 To eR Step dR
      For j = 2 To eC
        If Len(DK(i, j)) > 0 And Len(DK(i + 1, j)) > 0 And Len(DK(i + 3, j)) = 0 Then
          Size = DK(i, j): Mau = DK(i + 1, j)
          For k = 2 To sCol
            If sArr(1, k) = Size Then
              For n = 2 To sRow
                If sArr(n, 1) = Mau Then
                  Sl = sArr(n, k)
                  If Sl > 0 Then
                    dtBln = True
                    Do While Sl > 0
                      If Sl > iMax Then tmp = iMax Else tmp = Sl
                      Sl = Sl - tmp
                      If j > eC Then
                        i = i + dR
                        j = j - eC + 1
                      End If
                      With Sheets("TH2")
                        If i < eR Then
                          .Cells(i, j) = Size
                          .Cells(i + 1, j) = Mau
                          .Cells(i + 3, j) = tmp
                          DK(i + 3, j) = tmp
                        End If
                      End With
                      j = j + dC
                    Loop
                    GoTo Tiep
                  End If
                End If
              Next n
            End If
          Next k
        End If
      Next j
    Next i
Tiep:
  Next m
  If dtBln = False Then MsgBox ("Khong Co Du Lieu Phu Hop")
  Application.ScreenUpdating = True
End Sub

Sub XoaKetQua()
  Dim i
  Const fR = 2 'Dòng dau Sheet TH
  Const dR = 7 'Khoang cach ket qua
  Const sC = 30 'So cuoi

  With Sheets("TH2")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then
      Application.ScreenUpdating = False
      For i = fR To eRow Step dR
        .Range("B" & i).Resize(2, sC).ClearContents
        .Range("B" & i + 3).Resize(, sC).ClearContents
      Next i
      Application.ScreenUpdating = True
    End If
  End With
End Sub

Chạy code phải theo đúng trình tự, nếu không kết quả sẽ tùm lum

Cảm ơn anh rất nhiều, kết quả trả về chính xác.