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

  • PhanBo_nhieu (1).xlsm
    263.4 KB · Đọc: 5
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

  • PhanBo_Nhieu_DanDeu-HTN.xlsm
    142.5 KB · Đọc: 5
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

  • PhanBo_nhieu (CQ).xlsm
    262 KB · Đọc: 4
  • PhanBo_Nhieu_DanDeu-HTN.xlsm
    165.1 KB · Đọc: 6
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

  • PhanBo_nhieu (1).xlsm
    264.9 KB · Đọc: 9
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

A
Excel thiếu dữ liệu
Trả lời
3
Đọc
66
vietduc147258
V
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
1
Đọc
30
BuiQuangThuan
B
A
Đếm dữ liệu với điều kiện
Trả lời
11
Đọc
92
DeTong
D
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
29
Đọc
2K
vu_tuan_manh_linh
vu_tuan_manh_linh
T
V/v tối ưu xử lý đoạn code
Trả lời
4
Đọc
155
huhumalu
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

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

Back
Top Bottom