Giúp thay đổi dữ liệu theo điều kiện tổng (2 người xem)

[tueyennhi]

Em có bài toán như sau mong mọi người giúp đỡ:

Tại vùng dữ liệu từ cột BK đến CO ta có số liệu tổng là cột CP.

- Giả sử tại dòng 4: CP4=BJ4 thì ta giữ nguyên dữ liệu từ cột BK đến CO không thay đổi.

- Nếu dòng bất kỳ của cột CP >= dòng tương ứng cột BJ thì ta thay đổi số liệu trong cột bất kỳ từ BK đến CO của dòng đó sao cho tổng mới của CP <=BJ (Nếu bằng thì tốt quá vì em sợ như thế khó, còn nếu không được thì nhỏ hơn một chút xíu cũng được chỉ cần không chênh lệch quá).

- Số liệu thay đổi tại cell so với dữ liệu cũ của chính cell đó chỉ được phép nhỏ hơn và là số >=0, không được phép lớn hơn dữ liệu cũ..

"Bài toán này nếu vba excel có thể làm được thì thực sự kinh ngạc về khả năng của nó và em có thể học hỏi lên một bài học quý giá!"

*Theo gợi ý của bạn Befaint em biết thêm về Solver thì thấy chạy rất tốt nhưng chưa biết cách áp dụng để chạy cho toàn bộ bảng tính một lúc.

Em cảm ơn ạ!

 

[HieuCD]

Ừm, cảm ơn bạn nhé, mình đợi tin

chạy code mới

Sub GPE()
Dim Arr As Variant, i As Long, j As Integer, jMax As Integer, Col As Integer
Dim T1 As Double, T2 As Double, D As Double, Max As Double
Arr = Range("BK4:CO" & Range("BK" & Rows.Count).End(xlUp).Row).Value
Col = UBound(Arr, 2)
For i = 1 To UBound(Arr)
  T1 = Application.RoundDown(Range("BJ" & i + 3).Value, 2)
  T2 = Application.RoundDown(Range("CP" & i + 3).Value, 2)
  If T2 > T1 Then
    Max = 0:  D = 0
    For j = 1 To Col
      If Arr(i, j) > 0 Then
        If Max < Arr(i, j) Then Max = Arr(i, j): jMax = j
        Arr(i, j) = Arr(i, j) - Application.RoundDown((T2 - T1) * Arr(i, j) / T2, 2)
        D = D + Arr(i, j)
      End If
    Next j
    Arr(i, jMax) = Arr(i, jMax) + T1 - D
  End If
Next i
Range("BK4").Resize(UBound(Arr), Col) = Arr
End Sub

 

[tueyennhi]

Bạn thử chạy cái này xem sao

Option Explicit

Public Sub TueYenNhi()
Dim DArr, Res, MySum
Dim i As Long, j As Long, k

With Sheet4
Res = .Range("BJ4", .Range("BJ4").End(xlDown))
MySum = .Range("CP4", .Range("CP4").End(xlDown))
DArr = .Range("BK4", "CO" & .Range("CP1000000").End(xlUp).Row)
For i = 1 To UBound(MySum)
    If MySum(i, 1) > Res(i, 1) Then
        k = Res(i, 1) / MySum(i, 1)
            For j = 1 To UBound(DArr, 2)
                DArr(i, j) = DArr(i, j) * k
            Next j
    End If
Next i
.Range("BK4").Resize(UBound(DArr), UBound(DArr, 2)) = DArr
End With
End Sub

Nhiều cách hay quá . Cảm ơn bạn! Tuy nhiên con số của bạn HieuCD đẹp hơn, còn cách của bạn dễ hiểu hơn một chút

 

[tueyennhi]

Bạn HieuCD có thể giải thích dòng này giúp mình được không:

...
       D = D + Arr(i, j)
     End If
   Next j
   Arr(i, jMax) = Arr(i, jMax) + T1 - D
End If
...

 

[HieuCD]

Bạn HieuCD có thể giải thích dòng này giúp mình được không:

...
       D = D + Arr(i, j)
     End If
   Next j
   Arr(i, jMax) = Arr(i, jMax) + T1 - D
End If
...

T1 là tổng cần có của các ô
D là tổng các ô
T1 - D là chênh lệch cần điều chỉnh, dương phải tăng thêm ,âm phải giảm đi một ô nào đó
Arr(i, j) = Arr(i, j) + T1 - D
Nếu chênh lệch âm, khi điều chỉnh có thể dẫn đến ô chọn điều chỉnh bị giá trị âm
Mình chọn ô có giá trị lớn nhất để điều chỉnh để tất cả các ô điều dương
Arr(i, jMax) = Arr(i, jMax) + T1 - D

 

[tueyennhi]

T1 là tổng cần có của các ô
D là tổng các ô
T1 - D là chênh lệch cần điều chỉnh, dương phải tăng thêm ,âm phải giảm đi một ô nào đó
Arr(i, j) = Arr(i, j) + T1 - D
Nếu chênh lệch âm, khi điều chỉnh có thể dẫn đến ô chọn điều chỉnh bị giá trị âm
Mình chọn ô có giá trị lớn nhất để điều chỉnh để tất cả các ô điều dương
Arr(i, jMax) = Arr(i, jMax) + T1 - D

Mình xin chân thành cảm ơn bạn!!!