belirli rakamları içeren hücrelerden belirli toplama ulaşmak

[sacid55]

selamlar..
forumda aradım ama istediğim gibi birşeye ulaşamadım.
örnek tabloda belirli rakamlar var.
hangi rakamlar toplandığında belirlediğim toplama ulaşılıyor?
bunu görmek istiyorum.
ulaşılacak rakam 787 .
ama dosya ekleyemiyorum..excel dosyasında şu rakamlar var..
39
541
431
435
335
111
153
519
33
623
589
91
178
101
648
182
68

 

[mancubus]

excel üstadlarından tushar mehta'nın çözümü

Kullanımı:
- bütün veriler tek bir sütuna bitişik yazılmalı. arada boş satır olmamalı.
- sütundaki ilk hücreye kaç adet kombinasyon istenildiği yazılacak. bütün kombinasyonlar için 0 yazılmalı
- ikinci hücreye ulaşılmak istenen rakam (787) yazılmalı
- üçüncü hücreden başlayarak aşağıya doğru bu rakama ulaşmak için gereken rakamlar yazılacak.
- ilk hücreden son hücreye kadar seçilecek.
- startSearch isimli makro çalıştırılacak.

makro çalıştığı zaman rakamların yazılı olduğu sütunun sağına ulaşılmak istenilen rakam, süre, 3. satırdan başlayarak aşağıya doğru toplamı bu rakamı veren rakamların sırasını farklı kombinasyonlar halinde veriyor.

Örnek:
C13'e 0
C14'e 787
C15'ten başlayarak C31'e kadar rakamlar.
C13:C31 aralığını seç.
makroyu çalıştır.

D13'ten başlayarak sonuç:
787, 00:55:52, 1, 4, 6, 9, 14, 17
787, 00:55:52, 1, 5, 6, 9, 12, 13
787, 00:55:52, 1, 5, 7, 12, 14, 17
787, 00:55:52, 1, 6, 7, 9, 12, 13, 16
787, 00:55:52, 1, 11, 12, 17
787, 00:55:52, 2, 13, 17
787, 00:55:52, 5, 6, 12, 16, 17

1 birinci sıradaki yani C15 hücresindeki rakamı, 4 dördüncü sıradaki yani C18 hücresindeki rakamı.......... gösterir.

Option Explicit
'http://www.tushar-mehta.com/excel/templates/match_values/index.html#VBA_multiple_combinations

Sub startSearch()
    'The selection should be a single contiguous range in a single column. _
     The first cell indicates the number of solutions wanted.  Specify zero for all. _
     The 2nd cell is the target value. _
     The rest of the cells are the values available for matching. _
     The output is in the column adjacent to the one containing the input data.
    
    If Not TypeOf Selection Is Range Then GoTo ErrXIT
    If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
    If Selection.Rows.Count < 3 Then GoTo ErrXIT
    
    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
        HaveRandomNegatives As Boolean
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    HaveRandomNegatives = checkRandomNegatives(InArr)
    If Not HaveRandomNegatives Then
    ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
                & vbNewLine _
            & "It may take a lot longer to search for matches." & vbNewLine _
            & "OK to continue else Cancel", vbOKCancel) = vbCancel Then
        Exit Sub
        End If
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
        LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
    Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
    ReDim Preserve Rslt(UBound(Rslt) + 1)
    Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
    Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
        Application.WorksheetFunction.Transpose(Rslt)
    Exit Sub
ErrXIT:
    MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
        & "The selection should be a single contiguous range in a single column." & vbNewLine _
        & "The first cell indicates the number of solutions wanted.  Specify zero for all." & vbNewLine _
        & "The 2nd cell is the target value." & vbNewLine _
        & "The rest of the cells are the values available for matching." & vbNewLine _
        & "The output is in the column adjacent to the one containing the input data."
    End Sub

Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001)
    RealEqual = Abs(A - B) <= Epsilon
    End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal _
    Else ExtendRslt = CurrRslt & Separator & NewVal
    End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
        ByVal HaveRandomNegatives As Boolean, _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    Dim I As Integer
    For I = CurrIdx To UBound(InArr)
        If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then
            Rslt(UBound(Rslt)) = (CurrTotal + InArr(I)) _
                & Separator & Format(Now(), "hh:mm:ss") _
                & Separator & ExtendRslt(CurrRslt, I, Separator)
            If MaxSoln = 0 Then
                If UBound(Rslt) Mod 100 = 0 Then Debug.Print "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(I) > TargetVal + Epsilon) Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
                I + 1, _
                CurrTotal + InArr(I), Epsilon, Rslt(), _
                ExtendRslt(CurrRslt, I, Separator), _
                Separator
            If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
        Else
            'we've run out of possible elements and we _
             still don't have a match
            End If
        Next I
    End Sub
Function ArrLen(Arr()) As Integer
    On Error Resume Next
    ArrLen = UBound(Arr) - LBound(Arr) + 1
    End Function
Function checkRandomNegatives(Arr) As Boolean
    Dim I As Long
    I = LBound(Arr)
    Do While Arr(I) < 0 And I < UBound(Arr): I = I + 1: Loop
    If I = UBound(Arr) Then Exit Function
    Do While Arr(I) >= 0 And I < UBound(Arr): I = I + 1: Loop
    checkRandomNegatives = Arr(I) < 0
    End Function

 

[sacid55]

çok teşekkür ederim tam istediğim gibi olmuş...

 

[mancubus]

rica ederim.

bir başka uygulamada da yine bir üstad Harlan Grove'dan.

VBE'de tools-references'dan aşağıdakiler işaretlenmeli:
Microsoft Scripting Runtime
Microsoft VBScript Regular Expressions 1.0 / veya daha üstü: 5.5

arzu ettiğimiz rakamlar bir sütuna girildikten sonra findsums isimli makro çalıştırılıyor.

burada toplamı oluşturmada kullanılacak rakamların bulunduğu aralık inputbox aracılığı ile seçiliyor. hedef rakam yine inputbox'a giriliyor.

makro yeni bir sayfa açarak toplamı veren rakamları aralarına + koyarak listeliyor.

'Begin VBA Code
'By Harlan Grove
'https://groups.google.com/forum/#!topic/microsoft.public.excel.misc/YaCpKgfIxBQ

Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

Const TOL As Double = 0.000001 'modify as needed
Dim c As Variant

Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp

re.Global = True
re.IgnoreCase = True

On Error Resume Next

Set x = Application.InputBox(Prompt:="Enter range of values:", Title:="findsums", Default:="", Type:=8)

If x Is Nothing Then
    Err.Clear
    Exit Sub
End If

y = Application.InputBox(Prompt:="Enter target value:", Title:="findsums", Default:="", Type:=1)

If VarType(y) = vbBoolean Then
    Exit Sub
Else
    t = y
End If

On Error GoTo 0

Set dco = dc1
Set dcn = dc2

Call recsoln

For Each y In x.Value2
    If VarType(y) = vbDouble Then
        If Abs(t - y) < TOL Then
            recsoln "+" & Format(y)
        ElseIf dco.Exists(y) Then
            dco(y) = dco(y) + 1
        ElseIf y < t - TOL Then
            dco.Add Key:=y, Item:=1
            c = CDec(c + 1)
            Application.StatusBar = "[1] " & Format(c)
        End If
    End If
Next y

n = dco.Count

ReDim v(1 To n, 1 To 3)

For k = 1 To n
    v(k, 1) = dco.Keys(k - 1)
    v(k, 2) = dco.Items(k - 1)
Next k

qsortd v, 1, n

For k = n To 1 Step -1
    v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
    If v(k, 3) > t Then dcn.Add Key:="+" & Format(v(k, 1)), Item:=v(k, 1)
Next k

On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

For k = 2 To n
    dco.RemoveAll
    swapo dco, dcn
    
    For Each y In dco.Keys
        p = False
        For j = 1 To n
            If v(j, 3) < t - dco(y) - TOL Then Exit For
            x = v(j, 1)
            s = "+" & Format(x)
            If Right(y, Len(s)) = s Then p = True
                If p Then
                    re.Pattern = "\" & s & "(?=(\+|$))"
                    If re.Execute(y).Count < v(j, 2) Then
                        u = dco(y) + x
                        If Abs(t - u) < TOL Then
                        recsoln y & s
                    ElseIf u < t - TOL Then
                        dcn.Add Key:=y & s, Item:=u
                        c = CDec(c + 1)
                        Application.StatusBar = "[" & Format(k) & "] " & Format(c)
                    End If
                End If
            End If
        Next j
    Next y
    If dcn.Count = 0 Then Exit For
Next k

If (recsoln() = 0) Then MsgBox Prompt:="all combinations exhausted", Title:="No Solution"

CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False

End Sub

Private Function recsoln(Optional s As String)

Const OUTPUTWSN As String = "findsums solutions" 'modify to taste
Static r As Range
Dim ws As Worksheet

If s = "" And r Is Nothing Then
    On Error Resume Next
    Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
    If ws Is Nothing Then
        Err.Clear
        Application.ScreenUpdating = False
        Set ws = ActiveSheet
        Set r = Worksheets.Add.Range("A1")
        r.Parent.Name = OUTPUTWSN
        ws.Activate
        Application.ScreenUpdating = True
    Else
        ws.Cells.Clear
        Set r = ws.Range("A1")
    End If
    recsoln = 0
ElseIf s = "" Then
    recsoln = r.Row - 1
    Set r = Nothing
Else
    r.Value = s
    Set r = r.Offset(1, 0)
    recsoln = r.Row - 1
End If

End Function

Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim j As Long, pvt As Long

If (lft >= rgt) Then Exit Sub
swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
pvt = lft

For j = lft + 1 To rgt
    If v(j, 1) > v(lft, 1) Then
        pvt = pvt + 1
        swap2 v, pvt, j
    End If
Next j

swap2 v, lft, pvt
qsortd v, lft, pvt - 1
qsortd v, pvt + 1, rgt

End Sub

Private Sub swap2(v As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim t As Variant, k As Long

For k = LBound(v, 2) To UBound(v, 2)
    t = v(i, k)
    v(i, k) = v(j, k)
    v(j, k) = t
Next k

End Sub

Private Sub swapo(a As Object, b As Object)

Dim t As Object

Set t = a
Set a = b
Set b = t

End Sub
'---- end VBA code ----