Soru Toplamı eşitleme

[işsiz123]

Merhabalar
A Sütununda alt alta tutarlar mevcut. Benim istediğim B1 hücresine yazdığım tutarlara eşit yada yakın olanları bulmak istiyorum.

Örnek

A	B
40	600
100	Yukarıya B1 hücresine 600 yazınca A sütununda toplamları 600 eşit veya en yakın olanları işaretlemesini istiyorum. Toplamaları 601
700
400
15
900
9800
71
30
6

 

[kulomer46]

Merhaba

Aşağıdaki program işinizi görür.

Hayırlı çalışmalar dilerim.

Selamlar...

 

[işsiz123]

Merhaba

Aşağıdaki program işinizi görür.

Hayırlı çalışmalar dilerim.

Selamlar...

Teşekkürler ,
Altın Üye olmadığım için dosyayı indiremiyorum size zahmet harici olarak link verebilir misiniz.

 

[kulomer46]

Merhaba

İnternette bir sıkıntı var.

Harici linke dosyayı yükleyemedim.

 

[kulomer46]

Tekrar Merhaba

Forumdaki müsait bir arkadaş yukardaki #2 numaralı mesajda eklediğim dosyayı indirip, harici linke yükleyip, linki burda paylaşabilirse iyi olur.

İşyerimdeki internetimden denedim yükleyemedim.

Hayırlı çalışmalar dilerim.

 

[Korhan Ayhan]

Harici Link (Silinebilir) ; https://dosya.co/j5nrrql1pcgc/A_Sütunundaki_Sayılarla_Hedef_Sayıyı_Veren_Toplamlar_(Vers._1).xlsm.html

 

[alicimri]

Alternatif: Zamanında yabancı bir siteden bulduğum koda bazı değişiklikler yaparak soruya uydurdum.
Veriler A sütununda, Aranacak sayı D1 Hücresinde olması gerekiyor,, Sonuç E1 ve F1 hücrelerine geliyor.

Sub Combinations()
Application.ScreenUpdating = False
son = Cells(Rows.Count, 1).End(3).Row
For e = 1 To son
Dim rRng As Range, p
Dim vElements, lRow As Long, vresult As Variant
Set rRng = Range("A1", Range("A1").End(xlDown))
p = e
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Call CombinationsNP(vElements, CInt(p), vresult, lRow, 1, 1)
Next
Range("E1").Value = Range("B" & Application.Match(Application.Min(Columns(3)), Columns(3), 0))
Range("B" & Application.Match(Application.Min(Columns(3)), Columns(3), 0)).Copy Range("F1")
Range("F1").Replace What:="=", Replacement:=""
Columns("b:C").ClearContents
Application.ScreenUpdating = True
End Sub
Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer
For i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("B" & lRow) = "=" & Join(vresult, "+")
       'Range("C" & lRow) = Range("B" & lRow)
       Range("C" & lRow) = Abs(Range("d1").Value - (Range("B" & lRow)))
    Else
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
    End If
Next i
End Sub

 

[işsiz123]

Bir çok kod denedim satır sayısı yükseldiği için çok kasıyor. Manuel yapmaya devam edeceğiz başka bir alternatif bulana kadar. Herkese teşekkürler.

 

[Korhan Ayhan]

Arşiv konularını inceleyebilirsiniz.

Sorgu için arama sonuçları: kombinasyon

www.excel.web.tr