Liệt kê có bao nhiêu tổng theo điều kiện

[BinhTam]

Chào các bạn,

1. Mình có file excel đính kèm muốn thực hiện thêm cho nút "không trùng NPl1" :
Mình muốn nhận được vba code
liệt kê theo tổng "ô F3" của 3 maNPL bất kỳ theo bảng tra "B3:C37" (với điều kiện các mã ở cột NPL1 không lặp lại)
ví dụ : nhập tổng F3= 20.6666666666677 (Tổng của 3 MaNPL)
xuất ra 3 cột NPL1, NPl2,NPL3 như sau:
AH WS NC
WS RC LP
RC BK IU
BK AE DS
AE BA GY

2. Tương tự file excel đính kèm muốn thực hiện thêm cho nút "Hmany tong"
Vba code thực hiện liệt kê các tổng của 3 MaNPL bất kỳ theo bảng "B3:C37"( với điều kiện tổng không lặp lại)
ví dụ:
Total NPL1 NPL2 NPL3

20.66666667 AE BK DS
19.33333333 CA AE GD
11.33333333 CA AE BK
16.66666667 AE GD BK
18.66666667 CA GD BK
21.33333333 AE GD CD
14 BK CD BE
12 CD BE AH

Mong nhận thông tin trợ giúp từ các bạn.

 

[HieuCD]

1. Mình có file excel đính kèm muốn thực hiện thêm cho nút "không trùng NPl1" :
Mình muốn nhận được vba code
liệt kê theo tổng "ô F3" của 3 maNPL bất kỳ theo bảng tra "B3:C37" (với điều kiện các mã ở cột NPL1 không lặp lại)
ví dụ : nhập tổng F3= 20.6666666666677 (Tổng của 3 MaNPL)
xuất ra 3 cột NPL1, NPl2,NPL3 như sau:
AH WS NC
WS RC LP
RC BK IU
BK AE DS
AE BA GY

2. Tương tự file excel đính kèm muốn thực hiện thêm cho nút "Hmany tong"
Vba code thực hiện liệt kê các tổng của 3 MaNPL bất kỳ theo bảng "B3:C37"( với điều kiện tổng không lặp lại)
ví dụ:
Total NPL1 NPL2 NPL3

20.66666667 AE BK DS
19.33333333 CA AE GD
11.33333333 CA AE BK
16.66666667 AE GD BK
18.66666667 CA GD BK
21.33333333 AE GD CD
14 BK CD BE
12 CD BE AH

Mong nhận thông tin trợ giúp từ các bạn.

Xem code . . .

Sub XYZ2()
  Dim sArr(), res(), sRow&, i&, i2&, i3&, t#, t2#, t3#, tong#, k&
  Const e# = 10 ^ (-12) 'Sai so cho phep
  Const N& = 10 'So dong ket qua
 
  i = Range("B999999").End(xlUp).Row
  res = Range("B3:C" & i).Value
  Range("B3:C" & i).Sort Range("C3"), 1, Header:=xlNo
  sArr = Range("B3:C" & i).Value
  Range("B3:C" & i).Value = res
  ReDim res(1 To N, 1 To 3)
  tong = Range("F3").Value 'Tong can tìm
  sRow = UBound(sArr)
 
  For i = 1 To sRow - 2
Tiep:
    t = sArr(i, 2)
    If t >= tong Then Exit For
    For i2 = i + 1 To sRow - 1
      t2 = t + sArr(i2, 2)
      If t2 >= tong Then Exit For
      For i3 = i2 + 1 To sRow
        t3 = t2 + sArr(i3, 2)
        If t3 > tong + e Then
          Exit For
        ElseIf t3 >= tong - e Then
          k = k + 1
          res(k, 1) = sArr(i, 1)
          res(k, 2) = sArr(i2, 1)
          res(k, 3) = sArr(i3, 1)
          If k = N Then GoTo Ketqua
          If i < sRow - 2 Then i = i + 1: GoTo Tiep
        End If
      Next i3
    Next i2
  Next i
Ketqua:
  Range("G3").Resize(N, 3) = res
End Sub

Sub XYZ3()
  Dim sArr(), res(), sRow&, i&, i2&, i3&, t#, t2#, tong$, k&, dic As Object
  Const N& = 1000 'So dong ket qua
 
  Set dic = CreateObject("scripting.dictionary")
  sArr = Range("B3:C" & Range("B999999").End(xlUp).Row).Value
  sRow = UBound(sArr)
  ReDim res(1 To N, 1 To 4)
  For i = 1 To sRow - 2
    t = sArr(i, 2)
    For i2 = i + 1 To sRow - 1
      t2 = t + sArr(i2, 2)
      For i3 = i2 + 1 To sRow
        tong = CStr(t2 + sArr(i3, 2))
        If dic.exists(tong) = False Then
          dic.Add tong, ""
          k = k + 1
          res(k, 1) = tong
          res(k, 2) = sArr(i, 1)
          res(k, 3) = sArr(i2, 1)
          res(k, 4) = sArr(i3, 1)
          If k = N Then GoTo Ketqua
        End If
      Next i3
    Next i2
  Next i
Ketqua:
  Range("F16").Resize(N, 4) = res
End Sub

 

[BinhTam]

Xem code . . .

Sub XYZ2()
  Dim sArr(), res(), sRow&, i&, i2&, i3&, t#, t2#, t3#, tong#, k&
  Const e# = 10 ^ (-12) 'Sai so cho phep
  Const N& = 10 'So dong ket qua
 
  i = Range("B999999").End(xlUp).Row
  res = Range("B3:C" & i).Value
  Range("B3:C" & i).Sort Range("C3"), 1, Header:=xlNo
  sArr = Range("B3:C" & i).Value
  Range("B3:C" & i).Value = res
  ReDim res(1 To N, 1 To 3)
  tong = Range("F3").Value 'Tong can tìm
  sRow = UBound(sArr)
 
  For i = 1 To sRow - 2
    t = sArr(i, 2)
Tiep:
    If t >= tong Then Exit For
    For i2 = i + 1 To sRow - 1
      t2 = t + sArr(i2, 2)
      If t2 >= tong Then Exit For
      For i3 = i2 + 1 To sRow
        t3 = t2 + sArr(i3, 2)
        If t3 > tong + e Then
          Exit For
        ElseIf t3 >= tong - e Then
          k = k + 1
          res(k, 1) = sArr(i, 1)
          res(k, 2) = sArr(i2, 1)
          res(k, 3) = sArr(i3, 1)
          If k = N Then GoTo Ketqua
          If i < sRow - 2 Then i = i + 1: GoTo Tiep
        End If
      Next i3
    Next i2
  Next i
Ketqua:
  Range("G3").Resize(N, 3) = res
End Sub

Sub XYZ3()
  Dim sArr(), res(), sRow&, i&, i2&, i3&, t#, t2#, tong$, k&, dic As Object
  Const N& = 1000 'So dong ket qua
 
  Set dic = CreateObject("scripting.dictionary")
  sArr = Range("B3:C" & Range("B999999").End(xlUp).Row).Value
  sRow = UBound(sArr)
  ReDim res(1 To N, 1 To 4)
  For i = 1 To sRow - 2
    t = sArr(i, 2)
    For i2 = i + 1 To sRow - 1
      t2 = t + sArr(i2, 2)
      For i3 = i2 + 1 To sRow
        tong = CStr(t2 + sArr(i3, 2))
        If dic.exists(tong) = False Then
          dic.Add tong, ""
          k = k + 1
          res(k, 1) = tong
          res(k, 2) = sArr(i, 1)
          res(k, 3) = sArr(i2, 1)
          res(k, 4) = sArr(i3, 1)
          If k = N Then GoTo Ketqua
        End If
      Next i3
    Next i2
  Next i
Ketqua:
  Range("F16").Resize(N, 4) = res
End Sub

Hàm XYZ2 => kết quả tổng bị thay đổi.
Mình muốn tổng không bị thay đổi.

 

[Phuocam]

Chào các bạn,

1. Mình có file excel đính kèm muốn thực hiện thêm cho nút "không trùng NPl1" :
Mình muốn nhận được vba code
liệt kê theo tổng "ô F3" của 3 maNPL bất kỳ theo bảng tra "B3:C37" (với điều kiện các mã ở cột NPL1 không lặp lại)
ví dụ : nhập tổng F3= 20.6666666666677 (Tổng của 3 MaNPL)

Trường hợp trong F3 có giá trị là 10:

1. ER = 10

2. RC = 2 và KK = 8

3. BE = 4 và CB = 6

...

tức là có ít hơn 3 NVPL, nhưng tổng của nó vẫn bằng F3 thì có liệt kê hay không?

.

 

[HieuCD]

Hàm XYZ2 => kết quả tổng bị thay đổi.
Mình muốn tổng không bị thay đổi.

Đã chỉnh tí xíu code bài #2

 

[Phuocam]

liệt kê theo tổng "ô F3" của 3 maNPL bất kỳ theo bảng tra "B3:C37" (với điều kiện các mã ở cột NPL1 không lặp lại)
ví dụ : nhập tổng F3= 20.6666666666677 (Tổng của 3 MaNPL)

Chỉnh một chút code gốc của bạn:

Sub ABC()
  Dim sArr(), res(), sRow&, i&, i2&, i3&, t#, t2#, t3#, tong#, k&
  Const e# = 10 ^ (-12) 'Sai so cho phep
  Const N& = 10 'So dong ket qua
  
  i = Range("B999999").End(xlUp).Row
  res = Range("B3:C" & i).Value
  Range("B3:C" & i).Sort Range("C3"), 1, Header:=xlNo
  sArr = Range("B3:C" & i).Value
  Range("B3:C" & i).Value = res
  ReDim res(1 To N, 1 To 3)
  tong = Range("F3").Value 'Tong can tìm
  sRow = UBound(sArr)
  
 
  For i = 1 To sRow - 2
    t = sArr(i, 2)
    
    If t >= tong Then Exit For
    For i2 = i + 1 To sRow - 1
      t2 = t + sArr(i2, 2)
      If t2 >= tong Then Exit For
      For i3 = i2 + 1 To sRow
        t3 = t2 + sArr(i3, 2)
        
        If t3 > tong + e Then
       
          Exit For
        ElseIf t3 >= tong - e Then
          k = k + 1
          res(k, 1) = sArr(i, 1)
          res(k, 2) = sArr(i2, 1)
          res(k, 3) = sArr(i3, 1)
           GoTo Next_ID
          If k = N Then GoTo Ketqua
        End If
        
      Next i3
    Next i2
    
Next_ID:
  Next i

Ketqua:
  Range("G3").Resize(N, 3) = res
End Sub

 

[BinhTam]

Trường hợp trong F3 có giá trị là 10:

1. ER = 10

2. RC = 2 và KK = 8

3. BE = 4 và CB = 6

...

tức là có ít hơn 3 NVPL, nhưng tổng của nó vẫn bằng F3 thì có liệt kê hay không?

.

Không liệt kê vì cần 3 MaNPL