Nhờ giúp đỡ code phân bổ số lượng theo không vượt quá con số cho trước?

Liên hệ QC
3ii đã viết:
À em đã hiểu, như vậy đây là phương pháp dàn đều cho tất cả các ngày, như vậy nó lẻ là đúng rồi, một ý tưởng cũng khá hay, cũng có lúc em sẽ cần đến phương án dàn kiểu này.
Nếu dàn đều thì bác có theo phương án chặn theo max không, nếu chặn được max hoặc min nữa thì cũng sẽ hay đấy.
Nhấp chuột vào đây để mở rộng...
Chạy thử file đính kèm.
Max đã kiểm tra theo tiêu chuẩn, min có lẽ bạn chủ động kiểm tra xem sao
Mã: 
Option Explicit

Sub abc_()
Dim Nguon
Dim canTren, ct
Dim Tong0, Tong1
Dim Spb, Sodu
Dim Kq
Dim rws, cls
Dim Dic As Object
Dim i, j, k

With Sheet3
    rws = .Range("C" & Rows.Count).End(xlUp).Row
    Nguon = .Range("A3:W" & rws)
    rws = UBound(Nguon)
    cls = UBound(Nguon, 2)
End With
canTren = Sheet2.Range("B3", Sheet2.Range("C3").End(xlDown))
ReDim Kq(1 To rws, 1 To cls - 6)

Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(canTren)
    Dic(canTren(i, 1)) = canTren(i, 2)
Next i

For i = 1 To rws - 1 Step 2
    ct = Dic(Nguon(i, 2))
    Tong0 = Nguon(i, 5)
    Tong1 = Tong0 + Nguon(i, 6)
    Sodu = 0
    
    For j = 7 To cls
        Kq(i, j - 6) = Nguon(i, j)
        Spb = Nguon(i, j) * Tong1 \ Tong0
        If Spb > ct Then
            Kq(i + 1, j - 6) = ct
        Else
            Kq(i + 1, j - 6) = Spb
        End If
        Sodu = Sodu + Kq(i + 1, j - 6)
    Next j
    Sodu = Tong1 - Sodu
    
    k = 0
    Do While Sodu > 0
        j = k Mod UBound(Kq, 2) + 1
        k = k + 1
        If Kq(i + 1, j) + 1 < ct Then
            Kq(i + 1, j) = Kq(i + 1, j) + 1
            Sodu = Sodu - 1
        End If
    Loop
Next i
Sheet3.Range("G3").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
Set Dic = Nothing
End Sub
 

File đính kèm

3ii đã viết:
Em hiểu chỗ này vậy sếp đừng format là được , cứ để nguyên bản lẻ.. khi cần dùng số em có thể balance rồi làm tròn cũng được sếp ạ, đoạn này gần bờ nên sếp cứ để em tự bơi.
Nhấp chuột vào đây để mở rộng...
Bạn phân bổ dàn đều theo thủ tục dưới đây! Đảm bảo chuẩn kèo!

PHP: 
Option Explicit

Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
    
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
    
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
    
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
    
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
    
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
    
    For r = 1 To lngRow Step 2
        
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
            
            dblThayDoi = dblTemp + arrDuLieu(r, c)
            
            If dblThayDoi > dblSoMax Then
                arrDuLieu(r + 1, c) = dblSoMax
                dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
            
            Cols = lngCol - c
            Select Case Cols
            Case 1 To 6
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case 7
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
    
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
 

File đính kèm

Hoàng Trọng Nghĩa đã viết:
Bạn phân bổ dàn đều theo thủ tục dưới đây! Đảm bảo chuẩn kèo!

PHP: 
Option Explicit

Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
 
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
 
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
 
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
 
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
 
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
 
    For r = 1 To lngRow Step 2
    
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
        
            dblThayDoi = dblTemp + arrDuLieu(r, c)
        
            If dblThayDoi > dblSoMax Then
                arrDuLieu(r + 1, c) = dblSoMax
                dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
        
            Cols = lngCol - c
            Select Case Cols
            Case 1 To 6
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case 7
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
 
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
Nhấp chuột vào đây để mở rộng...
Sếp ơi, chuẩn 90% , còn 10% số dư chưa phân bổ hết phải cộng hết vào cuối nữa sếp:
1630308043453.png

CHAOQUAY đã viết:
Chạy thử file đính kèm.
Max đã kiểm tra theo tiêu chuẩn, min có lẽ bạn chủ động kiểm tra xem sao
Mã: 
Option Explicit

Sub abc_()
Dim Nguon
Dim canTren, ct
Dim Tong0, Tong1
Dim Spb, Sodu
Dim Kq
Dim rws, cls
Dim Dic As Object
Dim i, j, k

With Sheet3
    rws = .Range("C" & Rows.Count).End(xlUp).Row
    Nguon = .Range("A3:W" & rws)
    rws = UBound(Nguon)
    cls = UBound(Nguon, 2)
End With
canTren = Sheet2.Range("B3", Sheet2.Range("C3").End(xlDown))
ReDim Kq(1 To rws, 1 To cls - 6)

Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(canTren)
    Dic(canTren(i, 1)) = canTren(i, 2)
Next i

For i = 1 To rws - 1 Step 2
    ct = Dic(Nguon(i, 2))
    Tong0 = Nguon(i, 5)
    Tong1 = Tong0 + Nguon(i, 6)
    Sodu = 0
 
    For j = 7 To cls
        Kq(i, j - 6) = Nguon(i, j)
        Spb = Nguon(i, j) * Tong1 \ Tong0
        If Spb > ct Then
            Kq(i + 1, j - 6) = ct
        Else
            Kq(i + 1, j - 6) = Spb
        End If
        Sodu = Sodu + Kq(i + 1, j - 6)
    Next j
    Sodu = Tong1 - Sodu
 
    k = 0
    Do While Sodu > 0
        j = k Mod UBound(Kq, 2) + 1
        k = k + 1
        If Kq(i + 1, j) + 1 < ct Then
            Kq(i + 1, j) = Kq(i + 1, j) + 1
            Sodu = Sodu - 1
        End If
    Loop
Next i
Sheet3.Range("G3").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác tương tự trường hợp trên,nếu em thử con số phân bổ cho tất cả các số nếu còn số dư thì quay tít bác nhỉ, có cho nó cộng hết vào số cuối rồi thoát vòng lặp được không bác.
 
Lần chỉnh sửa cuối:
3ii đã viết:
Sếp ơi, chuẩn 90% , còn 10% số dư chưa phân bổ hết phải cộng hết vào cuối nữa sếp:
View attachment 265069


Cảm ơn bác tương tự trường hợp trên,nếu em thử con số phân bổ cho tất cả các số nếu còn số dư thì quay tít bác nhỉ, có cho nó cộng hết vào số cuối rồi thoát vòng lặp được không bác.
Nhấp chuột vào đây để mở rộng...
Ah, tôi quên vụ cột nó có 17 mà tôi lại cho nó là 7 bạn thử sửa lại cái này nha. Thử chạy lại có đúng không!

PHP: 
Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
    
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
    
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
    
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
    
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
    
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
    
    For r = 1 To lngRow Step 2
        
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
            
            dblThayDoi = dblTemp + arrDuLieu(r, c)
            
            If dblThayDoi > dblSoMax Then
                arrDuLieu(r + 1, c) = dblSoMax
                dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
            
            Cols = lngCol - c
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
    
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub


Chỉ thay thế ở chỗ Select Case thôi!

Mã: 
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
 
3ii đã viết:
Sếp ơi, chuẩn 90% , còn 10% số dư chưa phân bổ hết phải cộng hết vào cuối nữa sếp:
View attachment 265069


Cảm ơn bác tương tự trường hợp trên,nếu em thử con số phân bổ cho tất cả các số nếu còn số dư thì quay tít bác nhỉ, có cho nó cộng hết vào số cuối rồi thoát vòng lặp được không bác.
Nhấp chuột vào đây để mở rộng...
Bạn đưa file thử quay tít lên cho cụ thể nhé
 
hpkhuong đã viết:
Dùng công thức được hôn?

G4 =ROUND((G3/$E3)*($E3+$F3),0)
Nhấp chuột vào đây để mở rộng...
Công thức này của bác không thấy bắt theo giới hạn max nhỉ? với lại bài này em muốn dùng code bác à, cảm ơn bác.
Hoàng Trọng Nghĩa đã viết:
Ah, tôi quên vụ cột nó có 17 mà tôi lại cho nó là 7 bạn thử sửa lại cái này nha. Thử chạy lại có đúng không!

PHP: 
Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
 
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
 
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
 
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
 
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
 
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
 
    For r = 1 To lngRow Step 2
     
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
         
            dblThayDoi = dblTemp + arrDuLieu(r, c)
         
            If dblThayDoi > dblSoMax Then
                arrDuLieu(r + 1, c) = dblSoMax
                dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
         
            Cols = lngCol - c
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
 
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub


Chỉ thay thế ở chỗ Select Case thôi!

Mã: 
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
Nhấp chuột vào đây để mở rộng...
Sêp ơi, code trên W6 vẫn ra = 1710 nếu F5= 1000000 ===\.

CHAOQUAY đã viết:
Bạn đưa file thử quay tít lên cho cụ thể nhé
Nhấp chuột vào đây để mở rộng...
Sorry bác em gửi file, bác check giúp em.
Hoàng Trọng Nghĩa đã viết:
Ah, tôi quên vụ cột nó có 17 mà tôi lại cho nó là 7 bạn thử sửa lại cái này nha. Thử chạy lại có đúng không!

PHP: 
Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
  
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
  
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
  
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
  
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
  
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
  
    For r = 1 To lngRow Step 2
      
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
          
            dblThayDoi = dblTemp + arrDuLieu(r, c)
          
            If dblThayDoi > dblSoMax Then
                arrDuLieu(r + 1, c) = dblSoMax
                dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
          
            Cols = lngCol - c
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
  
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub


Chỉ thay thế ở chỗ Select Case thôi!

Mã: 
            Select Case Cols
            Case 1 To lngCol - 1
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol
                dblTemp = dblSoPhanBo - dblRemain
            End Select
Nhấp chuột vào đây để mở rộng...
Em gửi sếp file test , sếp xem giúp em nhé
 

File đính kèm

Lần chỉnh sửa cuối:
3ii đã viết:
Sêp ơi, code trên W6 vẫn ra = 1710 nếu F5= 1000000 ===\.
Nhấp chuột vào đây để mở rộng...
Bạn thay thủ tục cũ bằng thủ tục dưới đây! Phải test như thế mới ra kết quả đúng. Bạn test tiếp đi.

PHP: 
Option Explicit

Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
    
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
    
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
    
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
    
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
    
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
    
    For r = 1 To lngRow Step 2
        
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
            
            dblThayDoi = dblTemp + arrDuLieu(r, c)
            
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblTemp + arrDuLieu(r, c)
                Else
                    arrDuLieu(r + 1, c) = dblSoMax
                    dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
                End If
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
            
            Cols = lngCol - c
            Select Case Cols
            Case 1 To lngCol - 2
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol - 1
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
    
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
 
Hoàng Trọng Nghĩa đã viết:
Bạn thay thủ tục cũ bằng thủ tục dưới đây! Phải test như thế mới ra kết quả đúng. Bạn test tiếp đi.

PHP: 
Option Explicit

Sub PhanBo_DanDeu_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblSoPhanBo As Double, dblThayDoi As Double, dblTemp As Double, dblRemain As Double, dblTotal As Double
   
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
   
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
   
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
   
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
   
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
   
    For r = 1 To lngRow Step 2
       
        dblSoPhanBo = arrPhanBo(r, 1)
        dblRemain = dblSoPhanBo
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        dblTemp = Round(dblSoPhanBo / lngCol)
        dblTotal = dblTemp
        For c = 1 To lngCol
           
            dblThayDoi = dblTemp + arrDuLieu(r, c)
           
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblTemp + arrDuLieu(r, c)
                Else
                    arrDuLieu(r + 1, c) = dblSoMax
                    dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
                End If
            Else
                arrDuLieu(r + 1, c) = dblThayDoi
                dblRemain = dblRemain - dblTemp
            End If
           
            Cols = lngCol - c
            Select Case Cols
            Case 1 To lngCol - 2
                dblTemp = Round(dblRemain / Cols)
                dblTotal = dblTotal + dblTemp
            Case lngCol - 1
                dblTemp = dblSoPhanBo - dblRemain
            End Select
        Next
    Next
   
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
Nhấp chuột vào đây để mở rộng...
Ok rồi, chắc là ngon rồi sếp ạ ,cảm ơn sếp nhiều lắm, với Sub PhanBo_UuTien_HTN làm phiền sếp có thể làm tiếp cho em nếu còn số dư nó cũng để hết vào cuối như này được không sếp?
 
Với chỗ này:

Mã: 
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblTemp + arrDuLieu(r, c)
                Else

Bạn sửa lại như vầy cho nó đỡ mất thời gian tính lại một công đoạn:

Mã: 
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblThayDoi
                Else

3ii đã viết:
Ok rồi, chắc là ngon rồi sếp ạ ,cảm ơn sếp nhiều lắm, với Sub PhanBo_UuTien_HTN làm phiền sếp có thể làm tiếp cho em nếu còn số dư nó cũng để hết vào cuối như này được không sếp?
Nhấp chuột vào đây để mở rộng...

Trời ơi, được 2 bà Tưng rồi, lại muốn hốt luôn bà Tân V-lốc hay sao vậy trời! Để xem sao.
 
Hoàng Trọng Nghĩa đã viết:
Với chỗ này:

Mã: 
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblTemp + arrDuLieu(r, c)
                Else

Bạn sửa lại như vầy cho nó đỡ mất thời gian tính lại một công đoạn:

Mã: 
            If dblThayDoi > dblSoMax Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblThayDoi
                Else



Trời ơi, được 2 bà Tưng rồi, lại muốn hốt luôn bà Tân V-lốc hay sao vậy trời! Để xem sao.
Nhấp chuột vào đây để mở rộng...
Thời buổi này dịch vụ phải chọn gói sếp ạ. Ủa mà sếp cũng xem "bà Tân V-lốc" ạ kakaka.
Chắc tầm này sếp cũng mệt rồi khó mà theo lao được, em không làm phiền sếp nữa, có vấn đề gì em sẽ tìm hiểu rồi xử lý tiếp.
Cảm ơn sếp nhiều nhé.
 
3ii đã viết:
Thời buổi này dịch vụ phải chọn gói sếp ạ. Ủa mà sếp cũng xem "bà Tân V-lốc" ạ kakaka.
Chắc tầm này sếp cũng mệt rồi khó mà theo lao được, em không làm phiền sếp nữa, có vấn đề gì em sẽ tìm hiểu rồi xử lý tiếp.
Cảm ơn sếp nhiều nhé.
Nhấp chuột vào đây để mở rộng...
Cái Ưu tiên thì cập nhật không cần VLOOKUP và phân bổ vào cái cuối nghèo út ăn giàu út chịu phải không?
P/s: Dịch vụ trọn gói gì mà chả có ly cà phê nào hết trơn à! Qua dịch lời lãi gì tính một lần hết đó nha!
 
Hoàng Trọng Nghĩa đã viết:
Cái Ưu tiên thì cập nhật không cần VLOOKUP và phân bổ vào cái cuối nghèo út ăn giàu út chịu phải không?
P/s: Dịch vụ trọn gói gì mà chả có ly cà phê nào hết trơn à! Qua dịch lời lãi gì tính một lần hết đó nha!
Nhấp chuột vào đây để mở rộng...
OK , đồng ý sếp! Hi vọng sớm qua dịch để em gặp sếp làm trận tưng bừng ::?>>
 
3ii đã viết:
Công thức này của bác không thấy bắt theo giới hạn max nhỉ? với lại bài này em muốn dùng code bác à, cảm ơn bác.

Sêp ơi, code trên W6 vẫn ra = 1710 nếu F5= 1000000 ===\.


Sorry bác em gửi file, bác check giúp em.

Em gửi sếp file test , sếp xem giúp em nhé
Nhấp chuột vào đây để mở rộng...
Phân bổ cái file này xong là đi tù cả mớ, làm tới đây thôi. :cool::p:D
 

File đính kèm

3ii đã viết:
OK , đồng ý sếp! Hi vọng sớm qua dịch để em gặp sếp làm trận tưng bừng ::?>>
Nhấp chuột vào đây để mở rộng...
Ừ thì tưng bừng!

PHP: 
Sub PhanBo_UuTien_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblRemain As Double, dblThayDoi As Double
    
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
    
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
    
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
    
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
    
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
    
    For r = 1 To lngRow Step 2
        
        dblRemain = arrPhanBo(r, 1)
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
        
        For c = 1 To lngCol
            If dblRemain > 0 Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblRemain + arrDuLieu(r, c)
                Else
                    dblThayDoi = dblRemain + arrDuLieu(r, c)
                    If dblThayDoi > dblSoMax Then
                        arrDuLieu(r + 1, c) = dblSoMax
                        dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
                    Else
                        arrDuLieu(r + 1, c) = dblThayDoi
                        dblRemain = 0
                    End If
                End If
            Else
                arrDuLieu(r + 1, c) = arrDuLieu(r, c)
            End If
        Next
    Next
    
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
 
Hoàng Trọng Nghĩa đã viết:
Ừ thì tưng bừng!

PHP: 
Sub PhanBo_UuTien_HTN()
    Dim rngTieuChuan As Range
    Dim c As Byte, Cols As Byte
    Dim arrPhanBo, arrDuLieu, arrCode
    Dim shDuLieu As Worksheet, shTieuChuan As Worksheet
    Dim e As Long, r As Long, lngCol As Long, lngRow As Long
    Dim dblSoMax As Double, dblRemain As Double, dblThayDoi As Double
   
    Set shDuLieu = Sheets("DU_LIEU")
    Set shTieuChuan = Sheets("TIEU_CHUAN")
   
    shDuLieu.AutoFilterMode = False
    shTieuChuan.AutoFilterMode = False
   
    e = shTieuChuan.Range("B" & Rows.Count).End(xlUp).Row
    Set rngTieuChuan = shTieuChuan.Range("B3:B" & e)
   
    e = shDuLieu.Range("B" & Rows.Count).End(xlUp).Row + 1
    arrPhanBo = shDuLieu.Range("F3:F" & e).Value
    arrDuLieu = shDuLieu.Range("G3:W" & e).Value
    arrCode = shDuLieu.Range("B3:B" & e).Value
   
    lngRow = UBound(arrDuLieu, 1)
    lngCol = UBound(arrDuLieu, 2)
   
    For r = 1 To lngRow Step 2
       
        dblRemain = arrPhanBo(r, 1)
        dblSoMax = rngTieuChuan.Find(arrCode(r, 1), , xlValues, xlWhole).Offset(, 1).Value
       
        For c = 1 To lngCol
            If dblRemain > 0 Then
                If c = lngCol Then
                    arrDuLieu(r + 1, c) = dblRemain + arrDuLieu(r, c)
                Else
                    dblThayDoi = dblRemain + arrDuLieu(r, c)
                    If dblThayDoi > dblSoMax Then
                        arrDuLieu(r + 1, c) = dblSoMax
                        dblRemain = dblRemain - (dblSoMax - arrDuLieu(r, c))
                    Else
                        arrDuLieu(r + 1, c) = dblThayDoi
                        dblRemain = 0
                    End If
                End If
            Else
                arrDuLieu(r + 1, c) = arrDuLieu(r, c)
            End If
        Next
    Next
   
    shDuLieu.Range("G3:W" & e).Value = arrDuLieu
    shDuLieu.Range("A2:W2").AutoFilter
End Sub
Nhấp chuột vào đây để mở rộng...
Đã quá sếp ơi, code chạy lê tê quá, cảm ơn sếp nhiều:drinks:
 
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

H
Cách tạo nhắc nhở trong excel và tự động mở file khi có nhắc nhở
Trả lời
18
Đọc
6K
ongke0711
ongke0711
hoamattroicoi
Trích xuất file *.xml sang Excel cho hóa đơn điện tử áp dụng nghị định 123/2020
    • Thích
    • Yêu thích
    • Cảm ơn
5 6 7
Trả lời
121
Đọc
30K
kunkoi9390
K
vanle33
File không thao tác gì khi mở ra vẫn hỏi lưu lại khi tắt đi.
Trả lời
8
Đọc
91
vanle33
vanle33
N
Cách đánh số thứ tự không liên tục (đánh số lại từ đầu khi cột bên cạnh có giá trị)
Trả lời
5
Đọc
90
HieuCD
H
G
Chuyển Data từ hàng và cột về dạng cột
Trả lời
11
Đọc
153
ptm0412
ptm0412
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
    • Yêu thích
Trả lời
16
Đọc
2K
quyenpv
quyenpv
P
Tại sao khi đánh số thì bị mất hai số cuối
Trả lời
4
Đọc
18K
vanle33
vanle33
HeSanbi
  • Đã giải quyết
LocalizeXL v1.71 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3
Trả lời
58
Đọc
9K
HeSanbi
HeSanbi
linhvu2807
Lỗi hàm công thức Querry
Trả lời
0
Đọc
39
linhvu2807
linhvu2807
C
Tìm dữ liệu khác nhau trong 2 file hoặc 2 sheet trong excel
Trả lời
2
Đọc
123
HUONGHCKT
H
D
Paste dữ liệu, bỏ qua các cell ẩn
2
Trả lời
30
Đọc
45K
HUONGHCKT
H
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
3
Đọc
143
yaaasoo01
Y
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
0
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
B
Xin hàm đếm số lượng khách hàng theo 1 điều kiện và bỏ dữ liệu trùng.
Trả lời
11
Đọc
465
bipbo2008
B
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
2
Đọc
243
HeSanbi
HeSanbi
NguyenthiH
Sao dùng Ctl + H thay thế không đúng.
Trả lời
19
Đọc
260
NguyenthiH
NguyenthiH
N
Lỗi định dạng số Excel 2019 - Nguyên nhân và cách khắc phục
Trả lời
1
Đọc
52
ptm0412
ptm0412
huuthang_bd
Chia sẻ: Tạo thông báo nhắc nhở khi sắp đến ngày kỷ niệm
    • Thích
    • Yêu thích
2
Trả lời
39
Đọc
9K
ngocminhkte
ngocminhkte
HeSanbi
  • Đã giải quyết
ExcelController - Các hàm thực thi tác vụ linh hoạt cho Excel
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
HeSanbi
HeSanbi
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
10
Đọc
251
HUONGHCKT
H
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