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

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

thufpts

Thành viên hoạt động
Tham gia
6/8/12
Bài viết
157
Được thích
6
Giới tính
Nam
Nghề nghiệp
Bốc vác
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.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
thufpts đã viết:
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.
Nhấp chuột vào đây để mở rộng...

Bạn xem file đính kèm nhé.
 

File đính kèm

Upvote 0
Bạn điền số vào ô B2 rồi ấn nút Solve để tìm
 

File đính kèm

Upvote 0
thufpts đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Bài này dùng công thức cũng đơn giản mà.
Nếu lấy số nhỏ khi trị tuyệt đối của điều kiện 2 và 3 bằng nhau thì dùng công thức sau:
Mã: 
=IF(SUM($G$4:G4)-G4/2<$H$2,G4,"")
Nếu lấy số lớn thì dùng công thức sau:
Mã: 
=IF(SUM($G$4:G4)-G4/2<=$H$2,G4,"")
 
Upvote 0
befaint đã viết:
Bạn xem file đính kèm nhé.
Nhấp chuột vào đây để mở rộng...
em cám ơn bác nhiều lắm. em còn 1 chút này nữa thôi mong bác chỉ giáo.
em muốn ô I2 khi nhập vào nó sẽ không lấy những giá trị của cột G đã có tại cột H mà lấy kế tiếp như file này được không bác.
mong bác giúp em

Capture.jpg
 

File đính kèm

Upvote 0
huuthang_bd đã viết:
Bài này dùng công thức cũng đơn giản mà.
Nếu lấy số nhỏ khi trị tuyệt đối của điều kiện 2 và 3 bằng nhau thì dùng công thức sau:
Mã: 
=IF(SUM($G$4:G4)-G4/2<$H$2,G4,"")
Nếu lấy số lớn thì dùng công thức sau:
Mã: 
=IF(SUM($G$4:G4)-G4/2<=$H$2,G4,"")
Nhấp chuột vào đây để mở rộng...

em cám ơn bác. em cũng làm như bác rồi nhưng mà file nó có mấy nghìn dòng. đến lúc nó load nặng quá. vì vốn dĩ file em nó có quá nhiều link
 
Upvote 0
thufpts đã viết:
em cám ơn bác nhiều lắm. em còn 1 chút này nữa thôi mong bác chỉ giáo.
em muốn ô I2 khi nhập vào nó sẽ không lấy những giá trị của cột G đã có tại cột H mà lấy kế tiếp như file này được không bác.
mong bác giúp em
Nhấp chuột vào đây để mở rộng...

Quy luật nhập dữ liệu vào từ H2 -> M2 như nào bạn? Nhập liên tục và thứ tự từ H2 -> M2 hay là có trường hợp bỏ trống?
 
Upvote 0
befaint đã viết:
Quy luật nhập dữ liệu vào từ H2 -> M2 như nào bạn? Nhập liên tục và thứ tự từ H2 -> M2 hay là có trường hợp bỏ trống?
Nhấp chuột vào đây để mở rộng...

bao gồm cả 2 bác à. Ví dụ nếu H2 bỏ trống mà I2 được nhập 10 thì dãy 1 2 3 4 sẽ chuyển sang cột I.
nếu cột J2 được nhập 20 thì dữ liệu sẽ lấy kế tiếp là 567 không lấy 1234 nữa vì dữ liệu 1234 đã có tại cột I. giống kiểu lấy lũy kế ấy. chỉ là đảm bảo sao cho dữ liệu thỏa mã 1 trong 3 điều kiện mà em đã nêu.
 
Lần chỉnh sửa cuối:
Upvote 0
thufpts đã viết:
bao gồm cả 2 bác à. Ví dụ nếu H2 bỏ trống mà I2 được nhập 10 thì dãy 1 2 3 4 sẽ chuyển sang cột I.
nếu cột J2 được nhập 20 thì dữ liệu sẽ lấy kế tiếp là 567 không lấy 1234 nữa. giống kiểu lấy lũy kế ấy. chỉ là đảm bảo sao cho dữ liệu thỏa mã 1 trong 3 điều kiện mà em đã nêu.
Nhấp chuột vào đây để mở rộng...
Như vầy nhé.
1/ H2 nhập 10, IJK2 bỏ trống, L2 nhập 20, M2 nhập 30, có trường hợp này không?
2/ Sau khi nhập xong từ H2-M2 đầy đủ, sau đó bạn xóa J2, K2 đi chẳng hạn thì có nhập lại L2, M2 không? Nếu không nhập lại thì có cần cập nhật lại kết quả ở cột L và M không?
3/ Sau khi nhập xong từ H2-M2 đầy đủ, sau đó bạn chỉ thay đổi giá trị tại 1 trong các ô H2->M2 thì kết quả cần cập nhật lại không?
Nhiều vấn đề lắm, bạn ngâm cứu từ từ...
 
Upvote 0
befaint đã viết:
Như vầy nhé.
1/ H2 nhập 10, IJK2 bỏ trống, L2 nhập 20, M2 nhập 30, có trường hợp này không?
2/ Sau khi nhập xong từ H2-M2 đầy đủ, sau đó bạn xóa J2, K2 đi chẳng hạn thì có nhập lại L2, M2 không? Nếu không nhập lại thì có cần cập nhật lại kết quả ở cột L và M không?
3/ Sau khi nhập xong từ H2-M2 đầy đủ, sau đó bạn chỉ thay đổi giá trị tại 1 trong các ô H2->M2 thì kết quả cần cập nhật lại không?
Nhiều vấn đề lắm, bạn ngâm cứu từ từ...
Nhấp chuột vào đây để mở rộng...

Thưa bác. không hiểu sao bác nói đúng hết. tất cả các trường hợp đều có thể sảy ra.
và kể cả dữ liệu ở cột G thay đổi thì dữ liệu cũng cần cập nhật lại bác ạ.
em không biết cái này có làm khó được bác không nhưng đối với em là cái vực sâu rồi chẳng biết nên làm kiểu gì.
mong bác chỉ cho.
 
Upvote 0
thufpts đã viết:
Thưa bác. không hiểu sao bác nói đúng hết. tất cả các trường hợp đều có thể sảy ra.
và kể cả dữ liệu ở cột G thay đổi thì dữ liệu cũng cần cập nhật lại bác ạ.
em không biết cái này có làm khó được bác không nhưng đối với em là cái vực sâu rồi chẳng biết nên làm kiểu gì.
mong bác chỉ cho.
Nhấp chuột vào đây để mở rộng...

Bạn để ý ở dưới cuối trang web:
Hiện có 9 người đang xem đề tài này...
Nhấp chuột vào đây để mở rộng...
Có người đang xem giúp bài cho bạn đó. Không phải lo lắng ha!
 
Upvote 0
befaint đã viết:
Bạn để ý ở dưới cuối trang web:

Có người đang xem giúp bài cho bạn đó. Không phải lo lắng ha!
Nhấp chuột vào đây để mở rộng...

Bác không giúp em nữa sao..buồn quá Nhưng dù sao bác cũng giúp em quá nhiều rồi.
Trân trọng cám ơn bác rất nhiều.
chúc bác luôn vui vẻ.
 
Upvote 0
thufpts đã viết:
Bác không giúp em nữa sao..buồn quá Nhưng dù sao bác cũng giúp em quá nhiều rồi.
Trân trọng cám ơn bác rất nhiều.
chúc bác luôn vui vẻ.
Nhấp chuột vào đây để mở rộng...

Oh hay. Tôi có nói là không xem giúp bạn nữa đâu.
Bạn để ý dưới cuối trang web mà có cái nick nào xanh xanh đậm đậm trở lên là cứ yên tâm ha.
 
Upvote 0
HieuCD đã viết:
bạn xem thử có ổn không
Nhấp chuột vào đây để mở rộng...

Về cơ bản nó đã ổn theo dữ liệu trả về lũy kế. Nhưng về phần tính tổng vẫn không ổn bác ạ.
Dãy được tính tổng nó không sát với kết quả cho trước. chẳng hạn nhập 10 vào I2
Nó phải trả về dãy 4 và 5 tổng là 9 thì mới sát nhất bác ạ. Chứ nó chỉ trả về 4 thì chênh lệch quá nhiều
Bác xem giúp em với.


Capture.jpg
 
Upvote 0
thufpts đã viết:
Về cơ bản nó đã ổn theo dữ liệu trả về lũy kế. Nhưng về phần tính tổng vẫn không ổn bác ạ.
Dãy được tính tổng nó không sát với kết quả cho trước. chẳng hạn nhập 10 vào I2
Nó phải trả về dãy 4 và 5 tổng là 9 thì mới sát nhất bác ạ. Chứ nó chỉ trả về 4 thì chênh lệch quá nhiều
Bác xem giúp em với.
Nhấp chuột vào đây để mở rộng...
do không đọc yêu cầu của bạn nên hiểu nhầm, bạn sửa lại code sub GPE
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
    dk = Sarr(1, j)
    t1 = 0
    For i = 1 To UBound(Darr) - 1
        If Arr(i, LastC + 1) <> 123 Then
            t1 = t1 + Darr(i, 1)
            If t1 - Darr(i, 1) / 2 <= dk Then
                Arr(i, j) = Darr(i, 1): Arr(i, LastC + 1) = 123
            End If
        End If
    Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
do không đọc yêu cầu của bạn nên hiểu nhầm, bạn sửa lại code sub GPE
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
    dk = Sarr(1, j)
    t1 = 0
    For i = 1 To UBound(Darr) - 1
        If Arr(i, LastC + 1) <> 123 Then
            t1 = t1 + Darr(i, 1)
            If t1 - Darr(i, 1) / 2 <= dk Then
                Arr(i, j) = Darr(i, 1): Arr(i, LastC + 1) = 123
            End If
        End If
    Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...

Quá hoàn hảo luôn. Trân trong cám ơn các bác.
 
Upvote 0
befaint đã viết:
Vẫn có trường hợp chưa đúng --=0
Nhấp chuột vào đây để mở rộng...

em tìm mãi mới thấy cái này nghĩa là cách tính tổng có vấn đề. em thử thêm vào vài con số khác thì nó ra kết quả này.
có cách nào với trường hợp này nó sẽ chia con số 600 kia ra đẩy sang cột J, để tổng gần nhất với số cho trước là 500 không

Capture.jpg
 

File đính kèm

  • Capture.jpg
    Capture.jpg
    14.9 KB · Đọc: 27
Lần chỉnh sửa cuối:
Upvote 0
thufpts đã viết:
em tìm mãi mới thấy cái này nghĩa là cách tính tổng có vấn đề. em thử thêm vào vài con số khác thì nó ra kết quả này.
có cách nào với trường hợp này nó sẽ chia con số 600 kia ra đẩy sang cột J, để tổng gần nhất với số cho trước là 500 không

View attachment 167661
Nhấp chuột vào đây để mở rộng...

Trường hợp bạn nêu là do dữ liệu cột G khác với file bài #1 (cái tội giả lập dữ liệu không khớp với dữ liệu thật, quy luật sẽ khác nhau). Cái này khác với cái tôi phát hiện.
Mà sửa code thì tìm chủ nhân nhá. Tôi không được phép.
 
Upvote 0
vâng cảm ơn bác rất nhiều. nói đúng ra thì em không tính toán được hết. chỉ là khi em nhập nó mới phát sinh vấn đề bác ạ.
 
Upvote 0
thufpts đã viết:
em tìm mãi mới thấy cái này nghĩa là cách tính tổng có vấn đề. em thử thêm vào vài con số khác thì nó ra kết quả này.
có cách nào với trường hợp này nó sẽ chia con số 600 kia ra đẩy sang cột J, để tổng gần nhất với số cho trước là 500 không

View attachment 167661
Nhấp chuột vào đây để mở rộng...

Hình này vẫn đúng với các điều kiện mà bạn đưa ra +-+-+-+
 
Upvote 0
huuthang_bd đã viết:
Hình này vẫn đúng với các điều kiện mà bạn đưa ra +-+-+-+
Nhấp chuột vào đây để mở rộng...

Ôi em hay bị tâm lý vì em thấy bác kia bao vẫn có chỗ chưa đúng hihihi nên em hỏi lại.
Em muốn nhờ các bác thêm 1 vấn đề nữa. em định post bài khác nhưng em nghĩ nó cùng 1 vấn đề.
Cũng với cách tính tổng này nhưng nó sẽ tính đúng với số tổng đã cho trước.
nghĩa là nếu tổng các giá trị lấy ra mà lớn hơn số tổng đã cho trước thì số tổng ban đầu phải trừ đi giá
trị cuối cùng trong dãy N đơn vị để tổng được tính bằng đúng với số tổng ban đầu.
số bị trừ sẽ được chuyển sang cột bên cạnh để cộng với các giá trị khác.

Ví dụ cụ thể em đã nhập lại số trong file mà các bác đã giúp em. em gửi lại để các bác xem.
Rất mong các bác giúp em.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
do không đọc yêu cầu của bạn nên hiểu nhầm, bạn sửa lại code sub GPE
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
    dk = Sarr(1, j)
    t1 = 0
    For i = 1 To UBound(Darr) - 1
        If Arr(i, LastC + 1) <> 123 Then
            t1 = t1 + Darr(i, 1)
            If t1 - Darr(i, 1) / 2 <= dk Then
                Arr(i, j) = Darr(i, 1): Arr(i, LastC + 1) = 123
            End If
        End If
    Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Em muốn nhờ các bác thêm 1 vấn đề nữa. em định post bài khác nhưng em nghĩ nó cùng 1 vấn đề.
Cũng với cách tính tổng này nhưng nó sẽ tính đúng với số tổng đã cho trước.
nghĩa là nếu tổng các giá trị lấy ra mà lớn hơn số tổng đã cho trước thì số tổng ban đầu phải trừ đi giá
trị cuối cùng trong dãy N đơn vị để tổng được tính bằng đúng với số tổng ban đầu.
số bị trừ sẽ được chuyển sang cột bên cạnh để cộng với các giá trị khác. em diễn tả hơi ngu tí
vì em không có logic
Ví dụ cụ thể em đã nhập lại số trong file mà các bác đã giúp em. em gửi lại để các bác xem.
Rất mong các bác giúp em.
 

File đính kèm

Upvote 0
thufpts đã viết:
Bác đừng tức giận. em nói thật là em không biết cái gì cả nên khi bác nói em sẽ tin.
vì mọi người đã giúp đỡ rất nhiệt tình. mong bác thông cảm
Nhấp chuột vào đây để mở rộng...

Ây dza. Đó là một câu khẳng định.
Nếu có gì không thích thì mình nghỉ chơi thôi.
p/s: Tôi chờ bạn kiểm tra các trường hợp của bạn, nếu nó không xảy ra lỗi đó thì cũng không cần thiết chỉnh lại. Thực tế mà không xảy ra thì bỏ qua thôi.
 
Upvote 0
befaint đã viết:
Ây dza. Đó là một câu khẳng định.
Nếu có gì không thích thì mình nghỉ chơi thôi.
p/s: Tôi chờ bạn kiểm tra các trường hợp của bạn, nếu nó không xảy ra lỗi đó thì cũng không cần thiết chỉnh lại. Thực tế mà không xảy ra thì bỏ qua thôi.
Nhấp chuột vào đây để mở rộng...

em thấy chạy ổn bác ạ. chỉ là em nhờ các bác thêm 1 trường hợp tính tổng đúng với số cho trước em vừa nêu trên thôi
em mong các bác giúp em.
 
Upvote 0
thufpts đã viết:
Em muốn nhờ các bác thêm 1 vấn đề nữa. em định post bài khác nhưng em nghĩ nó cùng 1 vấn đề.
Cũng với cách tính tổng này nhưng nó sẽ tính đúng với số tổng đã cho trước.
nghĩa là nếu tổng các giá trị lấy ra mà lớn hơn số tổng đã cho trước thì số tổng ban đầu phải trừ đi giá
trị cuối cùng trong dãy N đơn vị để tổng được tính bằng đúng với số tổng ban đầu.
số bị trừ sẽ được chuyển sang cột bên cạnh để cộng với các giá trị khác. em diễn tả hơi ngu tí
vì em không có logic
Ví dụ cụ thể em đã nhập lại số trong file mà các bác đã giúp em. em gửi lại để các bác xem.
Rất mong các bác giúp em.
Nhấp chuột vào đây để mở rộng...
bạn chạy code thử
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
bạn chạy code thử
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
bác giỏi quá. bái phục luôn. quá chuẩn, tuyệt vời
 
Upvote 0
HieuCD đã viết:
bạn chạy code thử
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...

Bác ơi nếu em muốn tùy chọn các cột để nhập số tổng bất kỳ ví dụ H2, K2, M2 .... thì làm thế nào vậy bác
 
Upvote 0
HieuCD đã viết:
code cho phép nhập số tổng vào H2...M2, bạn nhập thử, nếu có vấn đề thì báo cụ thể, mình sẽ kiểm tra lại
Nhấp chuột vào đây để mở rộng...
Vâng code của bác quá tuyệt rồi.
ý em là em chỉ muốn thiết lập thêm tùy chọn cho các cột nhập số tổng
nghĩa là chỉ những cột nào được thiết lập thì mới tính tổng,
cột không được thiết lập số tổng cho trước nếu có nhập giá trị thì cũng sẽ không được tính tổng.
vị dụ như Cột J như hình bên dưới.
Capture.jpg
 
Upvote 0
thufpts đã viết:
Vâng code của bác quá tuyệt rồi.
ý em là em chỉ muốn thiết lập thêm tùy chọn cho các cột nhập số tổng
nghĩa là chỉ những cột nào được thiết lập thì mới tính tổng,
cột không được thiết lập số tổng cho trước nếu có nhập giá trị thì cũng sẽ không được tính tổng.
vị dụ như Cột J như hình bên dưới.
Nhấp chuột vào đây để mở rộng...
không chạy code cột J? nếu vậy phải có nơi ghi nhận điều kiện như dòng 3 nhập Ok mới chạy cột nầy?
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
[COLOR=#ff0000]Sarr = Sheet1.Range("H2:M3").Value[/COLOR]
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
[COLOR=#ff0000]    If Sarr(1, j) > 0 And Sarr(2, j) = "Ok" Then[/COLOR]
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
không chạy code cột J? nếu vậy phải có nơi ghi nhận điều kiện như dòng 3 nhập Ok mới chạy cột nầy?
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
[COLOR=#ff0000]Sarr = Sheet1.Range("H2:M3").Value[/COLOR]
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
[COLOR=#ff0000]    If Sarr(1, j) > 0 And Sarr(2, j) = "Ok" Then[/COLOR]
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Nó không chạy được bác ạ. em nhập số vào các Ô khác nó không chạy ra kết quả
 
Upvote 0
bạn xem file, trong code mình chỉnh ok theo chữ thường cho bạn dễ nhập
 

File đính kèm

Upvote 0
HieuCD đã viết:
vị trí các ô ở các sheet khác có giống với sheet1 không?
Nhấp chuột vào đây để mở rộng...
Có khác bác ạ. đôi khi em sẽ điều chỉnh em nhìn code của bác em có thể điều chỉnh được. nhưng em không biết làm sao để áp dụng cho nhiều sheet
 
Lần chỉnh sửa cuối:
Upvote 0
thufpts đã viết:
Có khác bác ạ. đôi khi em sẽ điều chỉnh em nhìn code của bác em có thể điều chỉnh được. nhưng em không biết làm sao để áp dụng cho nhiều sheet
Nhấp chuột vào đây để mở rộng...
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Ok rồi bác ạ. chạy ngon quá
 
Upvote 0
HieuCD đã viết:
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi sau một thời gian chạy em thấy em cần phải di chuyển cột chứa chữ OK thành hàng dọc. ở 1 cột bất kì chẳng hạn cột F.
và mỗi khi nhập ok thì giá trị ở cột G tương ứng mới được tính toán còn không thì bỏ qua. Ví dụ như ảnh bên dưới em đính kèm cả file mong bác giúp em với.

Capture.jpg
 

File đính kèm

Upvote 0
thufpts đã viết:
Bác ơi sau một thời gian chạy em thấy em cần phải di chuyển cột chứa chữ OK thành hàng dọc. ở 1 cột bất kì chẳng hạn cột F.
và mỗi khi nhập ok thì giá trị ở cột G tương ứng mới được tính toán còn không thì bỏ qua. Ví dụ như ảnh bên dưới em đính kèm cả file mong bác giúp em với.
Nhấp chuột vào đây để mở rộng...
bạn nên nhập "ok" ở cột F cho code viết gọn, nếu cột khác F thì báo mình viết lại
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("F4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Darr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 2)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 2)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 2) - t1
                    Darr(i, 2) = Darr(i, 2) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
bạn nên nhập "ok" ở cột F cho code viết gọn, nếu cột khác F thì báo mình viết lại
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("F4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Darr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 2)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 2)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 2) - t1
                    Darr(i, 2) = Darr(i, 2) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
 
Upvote 0
thufpts đã viết:
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Những yêu cầu dạng này thì nên làm dạng UDF cho dễ dùng.
PHP: 
Function RevTotalTable(RowTotal As Variant, ColTotal As Variant) As Variant
Dim CallerRng As Range, Result() As Variant, i As Long, j As Long, Tmp As Variant, iCol As Long, ArrRow() As Double, ArrCol() As Double, MinVal As Double
On Error Resume Next
Set CallerRng = Application.Caller
If CallerRng Is Nothing Then Exit Function
ReDim ArrRow(1 To CallerRng.Rows.Count)
ReDim ArrCol(1 To CallerRng.Columns.Count)
ReDim Result(1 To CallerRng.Rows.Count, 1 To CallerRng.Columns.Count) As Variant
For Each Tmp In RowTotal
    i = i + 1
    ArrRow(i) = Tmp
Next
i = 0
Tmp = ArrCol
For Each Tmp In ColTotal
    i = i + 1
    ArrCol(i) = Tmp
Next
iCol = 1
For i = 1 To UBound(ArrRow, 1)
    For j = iCol To UBound(ArrCol, 1)
        MinVal = IIf(ArrRow(i) < ArrCol(j), ArrRow(i), ArrCol(j))
        If MinVal > 0 Then
            Result(i, j) = MinVal
            ArrRow(i) = ArrRow(i) - MinVal
            ArrCol(j) = ArrCol(j) - MinVal
        End If
        If ArrRow(i) = 0 Then Exit For
    Next
Next
RevTotalTable = Result
End Function
 

File đính kèm

Upvote 0
thufpts đã viết:
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
Nhấp chuột vào đây để mở rộng...
khi cần thay đổi cột thì chỉnh lại cột F trong Oarr= ....
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr(), Oarr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Oarr = Sheet1.Range("F4:F" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Oarr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
huuthang_bd đã viết:
Những yêu cầu dạng này thì nên làm dạng UDF cho dễ dùng.
PHP: 
Function RevTotalTable(RowTotal As Variant, ColTotal As Variant) As Variant
Dim CallerRng As Range, Result() As Variant, i As Long, j As Long, Tmp As Variant, iCol As Long, ArrRow() As Double, ArrCol() As Double, MinVal As Double
On Error Resume Next
Set CallerRng = Application.Caller
If CallerRng Is Nothing Then Exit Function
ReDim ArrRow(1 To CallerRng.Rows.Count)
ReDim ArrCol(1 To CallerRng.Columns.Count)
ReDim Result(1 To CallerRng.Rows.Count, 1 To CallerRng.Columns.Count) As Variant
For Each Tmp In RowTotal
    i = i + 1
    ArrRow(i) = Tmp
Next
i = 0
Tmp = ArrCol
For Each Tmp In ColTotal
    i = i + 1
    ArrCol(i) = Tmp
Next
iCol = 1
For i = 1 To UBound(ArrRow, 1)
    For j = iCol To UBound(ArrCol, 1)
        MinVal = IIf(ArrRow(i) < ArrCol(j), ArrRow(i), ArrCol(j))
        If MinVal > 0 Then
            Result(i, j) = MinVal
            ArrRow(i) = ArrRow(i) - MinVal
            ArrCol(j) = ArrCol(j) - MinVal
        End If
        If ArrRow(i) = 0 Then Exit For
    Next
Next
RevTotalTable = Result
End Function
Nhấp chuột vào đây để mở rộng...
Bác ơi với các này em đã cho vào file của em rồi nhưng mà có ít dòng thì không sao file em lên đến 40.000 dòng thì đợi nó tính toán lâu lắm. mất vài phút cho mỗi lần nhập. không còn cách nào khác hả bác.
 
Upvote 0
thufpts đã viết:
Bác ơi với các này em đã cho vào file của em rồi nhưng mà có ít dòng thì không sao file em lên đến 40.000 dòng thì đợi nó tính toán lâu lắm. mất vài phút cho mỗi lần nhập. không còn cách nào khác hả bác.
Nhấp chuột vào đây để mở rộng...
Khi tôi trả lời thì đó là cách tốt nhất mà tôi có thể làm được rồi.
Nếu các cách trước nhanh hơn thì bạn dùng các cách đó đi.
 
Upvote 0
HieuCD đã viết:
code xét "ok" vừa theo dòng và cột, để bạn dể tùy biến
Nhấp chuột vào đây để mở rộng...

cám ơn bác. chạy ổn rồi bác ạ. em không hiểu sao những người lập trình như bác lại nghĩ cách giải quyết nhanh đến vậy.
Những con số những dòng lệnh các bác xử lý nhanh gọn. em chịu không thể hiểu được.
 
Upvote 0
HieuCD đã viết:
code xét "ok" vừa theo dòng và cột, để bạn dể tùy biến
Nhấp chuột vào đây để mở rộng...
Bác ơi. trước khi em nhờ bác giúp em, em xin lỗi bác vì nói thật là em gặp phải tình trạng này
mà thực sự là em không biết trình bày thế nào cả.
Mãi tận hôm nay em nghĩ nát óc mới viết được ra ý tưởng mà đáng lẽ em phải nói từ lúc đầu.
Dữ liệu em dùng rất hay gặp phải tình trạng không phải theo từ trên xuống dưới nữa mà nó rải rác lắm.

Ngoài tùy chọn ok ở cột F em rất muốn có thêm các tùy chọn theo thứ tự ưu tiêu như 1,2,3,4,5,6,7,8
Cùng cột F nếu như tồn tại đồng thời một trong các giá trị ưu tiên như ok,1,2,3,4,5,6,7,8 thì sẽ ưu tiên tính tổng
ok trước sau đó mới đến 1,2,3,4,5,6,7,8 nghĩa là từ trái qua phải và nếu để 0 sẽ không được tính.

Em rất mong bác giúp em vì file của em nó hàng chuc nghìn dòng mà em ngồi làm bằng tay thì em nản và đau đầu lắm.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR 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), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    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
 
Upvote 0
HieuCD đã viết:
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR 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), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    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
Nhấp chuột vào đây để mở rộng...
Một phút bác làm bằng 1 năm em cày quốc. thế này đâu phải ma trận nữa. phải gọi là bát quoái trận của gia cát lượng. không hiểu bác làm kiểu gì nữa quá tuyệt vời luôn. cám ơn bác.
 
Upvote 0
HieuCD đã viết:
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR 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), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    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
Nhấp chuột vào đây để mở rộng...
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
 
Lần chỉnh sửa cuối:
Upvote 0
vnsmac đã viết:
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
Nhấp chuột vào đây để mở rộng...
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
Mã: 
ReDim Ok123(1 To UBound(Oarr) [COLOR=#ff0000]+ 1[/COLOR], 1 To 1)
 
Lần chỉnh sửa cuối:
Upvote 0
vnsmac đã viết:
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
Nhấp chuột vào đây để mở rộng...
Hiện tại em thấy ổn vì dù sao em vẫn có ok và chưa dùng toàn số.
 
Upvote 0
HieuCD đã viết:
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
Mã: 
ReDim Ok123(1 To UBound(Oarr) [COLOR=#ff0000]+ 1[/COLOR], 1 To 1)
Nhấp chuột vào đây để mở rộng...
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.
Capture.PNG
 
Upvote 0
thufpts đã viết:
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.
Nhấp chuột vào đây để mở rộng...
code trước là đánh thứ tự ưu tiên liên tục
code đánh thứ tự tùy ý
Mã: 
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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
23
Đọc
569
ptm0412
ptm0412
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi (1 người xem)
Trả lời
5
Đọc
65
phongvanvu
P
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
39
Đọc
12K
ongke0711
ongke0711
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
55
Đọc
22K
Gà Con yêu VBA
Gà Con yêu VBA
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
166
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code (1 người xem)
Trả lời
6
Đọc
114
ptm0412
ptm0412
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
5
Đọc
375
SA_DQ
SA_DQ
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
291
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
262
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
115
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
326
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
683
nghiabros
N
L
Nhờ hỗ trợ tìm hàm excel trả về giá trị
Trả lời
4
Đọc
123
lechuong174
L
SA_DQ
Copilot & giúp hỗ trợ nhập các ký tự đặt biệt
    • Thích
Trả lời
0
Đọc
87
SA_DQ
SA_DQ
GPE-Trợ Lý
[GPE20] BIỂU ĐỒ CHUYÊN NGHIỆP: PHÁ VỠ GIỚI HẠN 2 TRỤC CỦA EXCEL
    • Thích
    • Yêu thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
hadu8889
EXCEL TỰ ĐỘNG ĐÓNG KHI SỬA TEXT Ở TRÊN USERFORM
Trả lời
10
Đọc
253
LOGANWover
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
565
Đọc
78K
lacmatquan
L
H
Lấy giá trị format trong ô của excel
Trả lời
2
Đọc
175
LOGANWover
L
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom