Chọn các số trong dãy số để ra 1 số tổng cho trước

Liên hệ QC

MinhKhai

Giải pháp Ếc-xào
Tham gia
16/4/08
Bài viết
934
Được thích
568
Chào các anh chị trong diễn đàn.

Tôi có nhu cầu như sau: Tôi có 1 dãy số (gồm nhiều ô, các ô có giá trị bất kỳ). Tôi muốn tìm ra những ô nào trong dãy đó cộng với nhau sẽ ra 1 giá trị cho trước. Mỗi ô chỉ được cộng 1 lần. Không cần tìm hết các phương án thỏa mãn, chỉ cần tìm được 1 đáp án là đạt yêu cầu

Mong mọi người dùng giúp đỡ
 

File đính kèm

  • Book1.xls
    21.5 KB · Đọc: 206
Chào các anh chị trong diễn đàn.

Tôi có nhu cầu như sau: Tôi có 1 dãy số (gồm nhiều ô, các ô có giá trị bất kỳ). Tôi muốn tìm ra những ô nào trong dãy đó cộng với nhau sẽ ra 1 giá trị cho trước. Mỗi ô chỉ được cộng 1 lần. Không cần tìm hết các phương án thỏa mãn, chỉ cần tìm được 1 đáp án là đạt yêu cầu

Mong mọi người dùng giúp đỡ

Mình làm cho bạn nhé. nhưng phải
Mã:
Sub Chon2so()
Dim n As Long, k As Long, i As Long, ran As Range
k = InputBox(" nhap so can so sanh")
n = Worksheets("Sheet1").[C6500].End(xlUp).Row
For i = 3 To n
    For Each ran In Worksheets("Sheet1").Range("C2:C" & n)
        If Range("C" & i).Value + ran.Value = k Then
        MsgBox " so thu nhat co vi tri dong la:" & i & " so thu 2 co vi tri dong la:" & ran.Row
        Exit Sub
        End If
    Next
   
Next
MsgBox (" khong co 2 so thoa man")
End Sub
code để bạn thử đó
 
Upvote 0
Chào các anh chị trong diễn đàn.

Tôi có nhu cầu như sau: Tôi có 1 dãy số (gồm nhiều ô, các ô có giá trị bất kỳ). Tôi muốn tìm ra những ô nào trong dãy đó cộng với nhau sẽ ra 1 giá trị cho trước. Mỗi ô chỉ được cộng 1 lần. Không cần tìm hết các phương án thỏa mãn, chỉ cần tìm được 1 đáp án là đạt yêu cầu

Mong mọi người dùng giúp đỡ

Bài này phải dùng Solver mới xong!
Xem bài tương tự:
http://www.giaiphapexcel.com/forum/...-lọc-danh-sách-khách-hàng&p=232000#post232000
 
Upvote 0
Bạn thử Code này xem sao: (Mình nhầm mất rồi cứ nghĩ là tìm 2 ô)

Mã:
Sub FindCell()
Dim Tm, Dk, i, j
Tm = [C3:C248]: Dk = [H4]
For i = 1 To UBound(Tm, 1)
For j = i + 1 To UBound(Tm, 1)
If Tm(i, 1) + Tm(j, 1) = Dk Then
MsgBox "Cell C" & i + 2 & " va Cell C" & j + 2
Exit Sub
End If
Next: Next
MsgBox "Khong tim thay"
End Sub

Hoặc dùng Hàm UDF:

Mã:
Function MyFor(Rg As Range, Dk As Long)
Dim Tm, i, j
Tm = Rg
MyFor = "None Value"
For i = 1 To UBound(Tm, 1)
For j = i + 1 To UBound(Tm, 1)
If Tm(i, 1) + Tm(j, 1) = Dk Then
MyFor = "= " & Rg.Cells(i, 1).Address & " + " & Rg.Cells(j, 1).Address
Exit Function
End If
Next: Next
End Function


Tại ô H3 nhập: =MyFor(C3:C1000,H4)
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thử Code này xem sao:

Mã:
Sub FindCell()
Dim Tm, Dk, i, j
Tm = [C3:C248]: Dk = [H4]
For i = 1 To UBound(Tm, 1)
For j = i + 1 To UBound(Tm, 1)
If Tm(i, 1) + Tm(j, 1) = Dk Then
MsgBox "Cell C" & i + 2 & " va Cell C" & j + 2
Exit Sub
End If
Next: Next
MsgBox "Khong tim thay"
End Sub

Mình làm cho bạn nhé. nhưng phải
Mã:
Sub Chon2so()
Dim n As Long, k As Long, i As Long, ran As Range
k = InputBox(" nhap so can so sanh")
n = Worksheets("Sheet1").[C6500].End(xlUp).Row
For i = 3 To n
    For Each ran In Worksheets("Sheet1").Range("C2:C" & n)
        If Range("C" & i).Value + ran.Value = k Then
        MsgBox " so thu nhat co vi tri dong la:" & i & " so thu 2 co vi tri dong la:" & ran.Row
        Exit Sub
        End If
    Next
   
Next
MsgBox (" khong co 2 so thoa man")
End Sub
code để bạn thử đó

Bài toán này là tìm những ô để cộng với nhau ra một giá trị cho trước mà. Đâu phải là cộng hai ô đâu.
 
Upvote 0
Bài toán này là tìm những ô để cộng với nhau ra một giá trị cho trước mà. Đâu phải là cộng hai ô đâu.

Nhưng yêu cầu là chỉ cần tìm ra một cặp số thôi đã thảo mãn yêu cầu mà. Hơn nữa bạn đó biết vô đây hỏi chác là biết chút về VBA rùi nên viết để bạn đó có được một cách giải quyết đã." Còn gặp phải các cao thử thì luôn tìm ra cái tối ưu hóa cái đó mình biết" Như vậy bạn cho mình hỏi code của mình đã thỏa mãn yêu cầu chưa? " hỏi về mục đính ra kết quả"
 
Upvote 0
Nhưng yêu cầu là chỉ cần tìm ra một cặp số thôi đã thảo mãn yêu cầu mà. Hơn nữa bạn đó biết vô đây hỏi chác là biết chút về VBA rùi nên viết để bạn đó có được một cách giải quyết đã." Còn gặp phải các cao thử thì luôn tìm ra cái tối ưu hóa cái đó mình biết" Như vậy bạn cho mình hỏi code của mình đã thỏa mãn yêu cầu chưa? " hỏi về mục đính ra kết quả"

Đề bài dùng từ "những" chứ không phải "cặp". Có nhĩa là nếu không có cặp nào thoả mãn thì đấp án phải nới rộng ra 3, 4 ...

Như vậy những lời giải chỉ tìm cặp là không đạt yêu cầu.

Đó là chỉ nói chuyện yêu cầu. Riêng về "tối ưu" cũng có hai vấn đề:

1. Tối ưu lời giải, tức là nếu không có nhóm nào cộng lại ra đúng thì lằm sao? Trả về 0 hay cố gắng tìm nhóm có tổng gần nhất?

2. Tối ưu giải thuật, cái này thuật toán rất cao.

Muốn giản dị chỉ có cách duy nhất là dùng solver.
Nếu mò trên mạng sẽ có một số add-ins khác (chính solver cũng là một add-in) làm công việc này. Từ khoá "knapsack problem", "bài toán xếp ba lô"
 
Upvote 0
Đề bài dùng từ "những" chứ không phải "cặp". Có nhĩa là nếu không có cặp nào thoả mãn thì đấp án phải nới rộng ra 3, 4 ...

Như vậy những lời giải chỉ tìm cặp là không đạt yêu cầu.

Đó là chỉ nói chuyện yêu cầu. Riêng về "tối ưu" cũng có hai vấn đề:

1. Tối ưu lời giải, tức là nếu không có nhóm nào cộng lại ra đúng thì lằm sao? Trả về 0 hay cố gắng tìm nhóm có tổng gần nhất?

2. Tối ưu giải thuật, cái này thuật toán rất cao.

Muốn giản dị chỉ có cách duy nhất là dùng solver.
Nếu mò trên mạng sẽ có một số add-ins khác (chính solver cũng là một add-in) làm công việc này. Từ khoá "knapsack problem", "bài toán xếp ba lô"

Đúng rùi mình đã hiểu vấn đề rùi. Thank
 
Upvote 0
Làm thử vầy. Hình như thuật toán này gọi là thuật toán vét cạn.
PHP:
Function SumF(Num As Double, ParamArray Args() As Variant) As String
Dim Data(), Cll As Range, n As Long, k As Long, Arr(), Total As Double
For i = LBound(Args) To UBound(Args)
    For Each Cll In Args(i)
        If Val(Cll.Value) <> 0 Then
            n = n + 1
            ReDim Preserve Data(1 To 2, 1 To n)
            Data(1, n) = Val(Cll.Value)
            Data(2, n) = Cll.Address(0, 0)
        End If
    Next
Next
ReDim Arr(1 To 1)
Arr(1) = 1
Total = Data(1, 1)
n = 1
k = 1
Do While Num <> Total
    If Arr(1) = UBound(Data, 2) Then
        SumF = "#N/A"
        Exit Function
    End If
    If Total > Num Then
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total - Data(1, Arr(n)) + Data(1, k)
            Arr(n) = k
        End If
    Else
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total + Data(1, k)
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = k
        End If
    End If
Loop
For k = 1 To n
    SumF = SumF & "+" & Data(2, Arr(k))
Next
SumF = Replace(SumF, "+", "=", 1, 1)
End Function
 

File đính kèm

  • SumF.xls
    42 KB · Đọc: 618
Upvote 0
Đề bài dùng từ "những" chứ không phải "cặp". Có nhĩa là nếu không có cặp nào thoả mãn thì đấp án phải nới rộng ra 3, 4 ...

Như vậy những lời giải chỉ tìm cặp là không đạt yêu cầu.


"


Đúng là ý của tôi là như vậy. Tìm tổng của các nhóm số. Nhóm có bao nhiêu phần tử tuỳ ý, miễn mỗi phần tử không lặp lại
 
Upvote 0
Tuyệt vời, đúng ý của em. Cảm ơn bác rất nhiều.

Do em mới tập tành về VBA, nên em chưa hiểu rõ cách bác cho code "chọn lọc" như thế nào. Bác "diễn giải nôm na" được không ạ

Nôm na là thế này. Tôi giả sử dãy số của bạn gồm các số từ a đến z. Và tổng cho trước là Tổng

So a với tổng
Nếu a > tổng thì so b với tổng...
Nếu a < tổng thì so a + b với tổng
Nếu a + b > tổng thì so a + c với tổng...
Nếu a + b < tổng thì so a + b + c với tổng
...

Nếu a + ... + o + z <> tổng thì so a + ... + p với tổng
...

Cho đến khi tìm được tập số thỏa điều kiện.
 
Upvote 0
Làm thử vầy. Hình như thuật toán này gọi là thuật toán vét cạn.
PHP:
Function SumF(Num As Double, ParamArray Args() As Variant) As String
Dim Data(), Cll As Range, n As Long, k As Long, Arr(), Total As Double
For i = LBound(Args) To UBound(Args)
    For Each Cll In Args(i)
        If Val(Cll.Value) <> 0 Then
            n = n + 1
            ReDim Preserve Data(1 To 2, 1 To n)
            Data(1, n) = Val(Cll.Value)
            Data(2, n) = Cll.Address(0, 0)
        End If
    Next
Next
ReDim Arr(1 To 1)
Arr(1) = 1
Total = Data(1, 1)
n = 1
k = 1
Do While Num <> Total
    If Arr(1) = UBound(Data, 2) Then
        SumF = "#N/A"
        Exit Function
    End If
    If Total > Num Then
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total - Data(1, Arr(n)) + Data(1, k)
            Arr(n) = k
        End If
    Else
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total + Data(1, k)
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = k
        End If
    End If
Loop
For k = 1 To n
    SumF = SumF & "+" & Data(2, Arr(k))
Next
SumF = Replace(SumF, "+", "=", 1, 1)
End Function

Tôi không hiểu mấy về VBA, code này đã chỉ ra được địa chỉ ô thôi. Để dễ dàng nhận biết hơn nên chỉ ra các số đó và định dạng khác như là tô mầu hay chữ đậm thì tốt hơn. Mong mọi người xem xét.
 
Upvote 0
Tôi không hiểu mấy về VBA, code này đã chỉ ra được địa chỉ ô thôi. Để dễ dàng nhận biết hơn nên chỉ ra các số đó và định dạng khác như là tô mầu hay chữ đậm thì tốt hơn. Mong mọi người xem xét.

Hàm SumF đó đã tạo ra một chuỗi công thức để có tổng bằng tổng đưa ra. Bạn chỉ cần chuyển nó thành công thức. Sau đó nếu muốn biết nó là tổng của những ô nào thì chỉ cần chọn ô đó và nhấn F2, các ô trong công thức sẽ được tô màu viền. Nếu tô màu sẽ gặp rắc rối khi có nhiều tổng khác nhau cùng tìm trên một vùng dữ liệu.
 
Upvote 0
Hàm SumF đó đã tạo ra một chuỗi công thức để có tổng bằng tổng đưa ra. Bạn chỉ cần chuyển nó thành công thức. Sau đó nếu muốn biết nó là tổng của những ô nào thì chỉ cần chọn ô đó và nhấn F2, các ô trong công thức sẽ được tô màu viền. Nếu tô màu sẽ gặp rắc rối khi có nhiều tổng khác nhau cùng tìm trên một vùng dữ liệu.
Tôi hiểu và cũng nghĩ ra cách của bạn hướng dẫn. Tuy nhiên khi báo cáo các sếp hỏi "đồng nào mua mắm và đồng nào mua muối" thì chắc có lẽ tôi phải mang theo máy tính mới giải thích được bạn ạ. Dù gì thì sự giúp đỡ của bạn cũng đạt được 95% yêu cầu đặt ra, 5% còn lại là làm thủ công. Cám ơn và mong được tiếp thu ý kiến
 
Upvote 0
Tôi không hiểu mấy về VBA, code này đã chỉ ra được địa chỉ ô thôi. Để dễ dàng nhận biết hơn nên chỉ ra các số đó và định dạng khác như là tô mầu hay chữ đậm thì tốt hơn. Mong mọi người xem xét.

Vì tôi thấy bạn khuyên chứ không phải bạn nhờ nên tôi đưa ra quan điểm của tôi thôi. Cái này chỉ cần biết sơ sơ về VBA thôi cũng có thể làm tô màu được.
 
Upvote 0
Các bác cho em hỏi tìm tổ hợp gồm 3,4,... thỏa mãn tổng cho trước thay vì tìm tổ hợp bất kỳ như trên không ạ. Ví dụ em muốn tìm tổ hợp gồm 13 số từ 64 số để ra 1 tổng cho trước thay vì kết quả ra tận 21 số có tổng như vậy. Nhờ cao kiến ạ.
 
Upvote 0
Làm thử vầy. Hình như thuật toán này gọi là thuật toán vét cạn.
PHP:
Function SumF(Num As Double, ParamArray Args() As Variant) As String
Dim Data(), Cll As Range, n As Long, k As Long, Arr(), Total As Double
For i = LBound(Args) To UBound(Args)
    For Each Cll In Args(i)
        If Val(Cll.Value) <> 0 Then
            n = n + 1
            ReDim Preserve Data(1 To 2, 1 To n)
            Data(1, n) = Val(Cll.Value)
            Data(2, n) = Cll.Address(0, 0)
        End If
    Next
Next
ReDim Arr(1 To 1)
Arr(1) = 1
Total = Data(1, 1)
n = 1
k = 1
Do While Num <> Total
    If Arr(1) = UBound(Data, 2) Then
        SumF = "#N/A"
        Exit Function
    End If
    If Total > Num Then
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total - Data(1, Arr(n)) + Data(1, k)
            Arr(n) = k
        End If
    Else
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total + Data(1, k)
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = k
        End If
    End If
Loop
For k = 1 To n
    SumF = SumF & "+" & Data(2, Arr(k))
Next
SumF = Replace(SumF, "+", "=", 1, 1)
End Function
bác ơi, mình đưa thuật toán vô VBA , lúc qua bên excel xuất macros nó yêu cầu macros name mà không có thì làm sao chạy thuật toán đc bấc
 
Upvote 0
Làm thử vầy. Hình như thuật toán này gọi là thuật toán vét cạn.
PHP:
Function SumF(Num As Double, ParamArray Args() As Variant) As String
Dim Data(), Cll As Range, n As Long, k As Long, Arr(), Total As Double
For i = LBound(Args) To UBound(Args)
    For Each Cll In Args(i)
        If Val(Cll.Value) <> 0 Then
            n = n + 1
            ReDim Preserve Data(1 To 2, 1 To n)
            Data(1, n) = Val(Cll.Value)
            Data(2, n) = Cll.Address(0, 0)
        End If
    Next
Next
ReDim Arr(1 To 1)
Arr(1) = 1
Total = Data(1, 1)
n = 1
k = 1
Do While Num <> Total
    If Arr(1) = UBound(Data, 2) Then
        SumF = "#N/A"
        Exit Function
    End If
    If Total > Num Then
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total - Data(1, Arr(n)) + Data(1, k)
            Arr(n) = k
        End If
    Else
        If k = UBound(Data, 2) Then
            k = Arr(n - 1) + 1
            Total = Total - Data(1, Arr(n)) - Data(1, Arr(n - 1)) + Data(1, k)
            n = n - 1
            Arr(n) = k
        Else
            k = k + 1
            Total = Total + Data(1, k)
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = k
        End If
    End If
Loop
For k = 1 To n
    SumF = SumF & "+" & Data(2, Arr(k))
Next
SumF = Replace(SumF, "+", "=", 1, 1)
End Function
CODE này chạy rất nhanh, nhẹ - thuật giải thật tuyệt vời - Cảm ơn huuthang_bd rất nhiều
Nhưng là Function mới chỉ cho ra 1 đáp án
XIN GIÚP: Giờ muốn chuyển thành Sub để liệt kê hết các đáp án (các hoán vị lệt kê 1 lần) thì sửa code này như nào ?
 
Upvote 0
Web KT
Back
Top Bottom