Chọn dãy số sao cho tổng dãy số đó gần bằng nhất với số cho trước. (2 người xem)

[thufpts]

Em chào các bác. em có bài toán này nhưng với khả năng của em không giải quyết được.
Em có một dãy số bất kỳ tại cột G. khi em nhập một giá trị bất kì tại ô màu đỏ ví dụ là 60
thì tại cột H nó sẽ tự động lấy giá trị ở cột G từ trên xuông (bắt buộc) sao cho tổng
ở vùng màu vàng của côt H phải thỏa mãn 1 trong các điều kiện sau
1. bằng ô màu đỏ tại cột H
2. lớn hơn ô màu đỏ tại cột H với giá trị gần nhất ví dụ 61 (tùy vào tổng của vùng màu vàng)
3. nhỏ hơn ô màu đỏ tại cột H với giá trị gần nhất ví dụ 59 (tùy vào tổng của vùng màu vàng).
Mỗi khi giá trị ở cột G thay đổi thì giá trị của vùng màu vàng tại cột H sẽ thay đổi theo.
tương tự khi nhập giá trị bất kì cho các cột I,J,K,L,M
Em rất mong các bác cao thủ giúp em với. em cám ơn các bác nhiều lắm.

 

[thufpts]

cột F ok là phải có, nên nhập tới số lớn nhất là 17-1=16
còn nếu muốn nhập toàn số thì phải sửa code lại

chỉ cần chỉnh lại khai báo Ok123

ReDim Ok123(1 To UBound(Oarr) [COLOR=#ff0000]+ 1[/COLOR], 1 To 1)

Bác Hieu oi em nhập số gặp phải trường hợp nó không tính được ra kết quả bác ạ. dòng màu vàng
chỉ tính được 199 không đủ 213.

 

[HieuCD]

Bác Hieu oi em nhập số gặp phải trường hợp nó không tính được ra kết quả bác ạ. dòng màu vàng
chỉ tính được 199 không đủ 213.

code trước là đánh thứ tự ưu tiên liên tục
code đánh thứ tự tùy ý

Sub GPE()
Dim i As Long, n As Long, m As Long, LastR As Long, Max As Long, j As Integer
Dim Darr(), Sarr(), Arr(), Oarr(), Ok123()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR).Value
Sarr = Sheet1.Range("H2:P3").Value
ReDim Arr(1 To UBound(Darr), 1 To UBound(Sarr, 2))
Oarr = Sheet1.Range("F4:F" & LastR).Value
ReDim Ok123(1 To UBound(Oarr) [COLOR=#ff0000]+ 1[/COLOR], 1 To 1)
[COLOR=#ff0000]Max = WorksheetFunction.Max(Oarr)[/COLOR]
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To [COLOR=#ff0000]Max[/COLOR]
    For i = 1 To UBound(Oarr)
        If Oarr(i, 1) = m Then
            n = n + 1: Ok123(n, 1) = m: Exit For
        End If
    Next i
Next m
For m = 1 To n
    For j = 1 To UBound(Sarr, 2)
        If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
            For i = 1 To UBound(Darr)
                If Darr(i, 1) > 0 And Oarr(i, 1) = Ok123(m, 1) Then
                    If Darr(i, 1) <= Sarr(1, j) Then
                        Arr(i, j) = Darr(i, 1)
                    Else
                        Arr(i, j) = Sarr(1, j)
                    End If
                    Sarr(1, j) = Sarr(1, j) - Arr(i, j)
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    If Sarr(1, j) = 0 Then Exit For
                End If
            Next i
        End If
    Next j
Next m
Range("H4:P" & LastR).ClearContents
Sheet1.Range("H4").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub