Sarakkeessa A on (kokonais)lukuja. Rivien lukumäärä vaihtelee. Haluaisin löytää A-sarakkeesta ensimmäisen sellaisen yhdistelmän, jonka summa on X. Siis tuon X:n arvo vaihtelee joka kerta. Merkitsen X:n aina esim. soluun B1. Esimerkki: A-solussa olisi seuraavat luvut alkaen A2:sta (ykkös-rivillä on otsikoita):
6
7
10
5
2
3
Jos nyt kirjoittaisin soluun B1 arvon 12, ohjelma jollakin tavalla kertoisi minulle, että löytyy riveiltä 3 ja 5 (7 5=12). Jos kirjoittaisin arvon 18, ohjelman pitäisi kertoa, että löytyy riveiltä 2, 3 ja 5 (6 7 5=18).
Sitten jos hakisin arvoa, jota ei löydy millään yhdistelmällä, niin tarpeeksi hyvä versio ilmoittaisi, ettei löydy. Aivan älyttömän huippu versio alkaisi automaattisesti etsiä seuraavaa pienempää summaa.
summan tekijöiden etsiminen
bufguhgf
9
134
Vastaukset
- Kundepuu
Montako lukua maksimissaan ja montako lukua saa maksimissaan käyttää?
Vaikuttaa oleellisesti ongelman ratkaisun vaikeusasteeseen.
Keep EXCELing
@Kunde- Kundepuu
ja haluatko vielä kaikki variaatiot vai ekaksi löydetyn? Sekin vaikuttaa... ;-)
- bufguhgf
Satoja lukuja. Ehkä noin 300 voisi olla käytännössä maksimi. En tarvitse kaikkia variaatioita, vaan nimenomaan riittää yksi.
- bufguhgf
Jäi näköjään pois vastaus yhteen kysymykseen. Ei ole maksimirajaa sille, montako lukua saa käyttää.
tavoite luku solussa B2
tsekattavat luvut A2:AXX
tulos C2:CXX
nyt kaikki variaatiot tulikin samalla, jos tarttee vaan "ns". ekan niin muutellaan...
ja suorita makro Haeluvut()
kopioi koodi moduuliin...
Option Explicit
Function Uusitulos(Nykyinen, Uusi)
If Nykyinen = "" Then
Uusitulos = Uusi
Else
Uusitulos = Nykyinen & ";" & Uusi
End If
End Function
Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
Dim i As Integer
For i = Indeksi To UBound(Luvut)
If Abs(NykySumma Luvut(i) - Tavoite) <= Ero Then
If Nykyinen = "" Then
Tulos(UBound(Tulos)) = i 1
Else
Tulos(UBound(Tulos)) = Nykyinen & ";" & i 1
End If
Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i 1)
ReDim Preserve Tulos(UBound(Tulos) 1)
ElseIf Indeksi < UBound(Luvut) Then
Lukujono Tavoite, Luvut(), i 1, NykySumma Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i 1)
End If
Next i
End Sub
Sub Haeluvut()
Dim vika As Long
Dim i As Long
Dim Tavoite
Dim Tulos()
Dim Luvut()
Tavoite = Range("B2").Value
Range("C2:C1000") = ""
vika = Range("A65536").End(xlUp).Row
Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
ReDim Tulos(0)
Lukujono Tavoite, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
Range("A2").Offset(0, 2).Resize(UBound(Tulos) - LBound(Tulos) 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
End Sub
Keep EXCELing
@Kunde"Aivan älyttömän huippu versio alkaisi automaattisesti etsiä seuraavaa pienempää summaa."
tossapa se sitten... ;-)
Option Explicit
Function Uusitulos(Nykyinen, Uusi)
If Nykyinen = "" Then
Uusitulos = Uusi
Else
Uusitulos = Nykyinen & ";" & Uusi
End If
End Function
Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
Dim i As Integer
For i = Indeksi To UBound(Luvut)
If Abs(NykySumma Luvut(i) - Tavoite) <= Ero Then
If Nykyinen = "" Then
Tulos(UBound(Tulos)) = i 1
Else
Tulos(UBound(Tulos)) = Nykyinen & ";" & i 1
End If
Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i 1)
ReDim Preserve Tulos(UBound(Tulos) 1)
ElseIf Indeksi < UBound(Luvut) Then
Lukujono Tavoite, Luvut(), i 1, NykySumma Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i 1)
End If
Next i
End Sub
Sub Haeluvut()
Dim vika As Long
Dim i As Long
Dim Tavoite
Dim Tulos()
Dim Luvut()
Tavoite = Range("B2").Value
Range("C2:C1000") = ""
vika = Range("A65536").End(xlUp).Row
Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
ReDim Tulos(0)
i = 0
Do Until Not Range("C3") = ""
Lukujono Tavoite - i, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
Range("A2").Offset(1, 2).Resize(UBound(Tulos) - LBound(Tulos) 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
Range("A2").Offset(0, 2) = "Tavoite: " & Tavoite - i
i = i 1
Loop
End Sub
Keep EXCELing
@Kundejäi vahingossa tohon roikkumaan turha if vertailu kun funktiona sama
tässä korjattu versio...
Option Explicit
Function Uusitulos(Nykyinen, Uusi)
If Nykyinen = "" Then
Uusitulos = Uusi
Else
Uusitulos = Nykyinen & ";" & Uusi
End If
End Function
Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
Dim i As Integer
For i = Indeksi To UBound(Luvut)
If Abs(NykySumma Luvut(i) - Tavoite) <= Ero Then
Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i 1)
ReDim Preserve Tulos(UBound(Tulos) 1)
ElseIf Indeksi < UBound(Luvut) Then
Lukujono Tavoite, Luvut(), i 1, NykySumma Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i 1)
End If
Next i
End Sub
Sub Haeluvut()
Dim vika As Long
Dim i As Long
Dim Tavoite
Dim Tulos()
Dim Luvut()
Tavoite = Range("B2").Value
Range("C2:C1000") = ""
vika = Range("A65536").End(xlUp).Row
Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
ReDim Tulos(0)
i = 0
Do Until Not Range("C3") = ""
Lukujono Tavoite - i, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
Range("A2").Offset(1, 2).Resize(UBound(Tulos) - LBound(Tulos) 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
Range("A2").Offset(0, 2) = "Tavoite: " & Tavoite - i
i = i 1
Loop
End Sub
Keep EXCELing
@Kunde- bufguhgf
Wau! Toimii. Näköjään tuolla ohjelmalla voi tehdä melkein mitä vaan. Suuret kiitokset.
- Kundepuu
hyvä, että oli toiveiden mukainen.
VBA kyllä taipuu Excelissä melko monimutkaisiin juttuihin ;-)
Keep EXCELing
@Kunde
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Kuka oli töllöntyön tekijä?
Ketä on nyt pidätetty? Oliko syy mustasukkaisuus tyttöystävästä tai oliko muita lieventäviä seikkoja? Katuuko tekijä nyt505267Kotikasvatus siitä se lähtee eli missä meni vikaan että lapsesta tuli puukottaja
Ottakaa muut oppia, normaali kotielämä. Ei liikaa edes hengellisyyttä.813064Vihamielisyys naisia kohtaan on jo yllättävän suuri ongelma
Esiintyy laajemmassa mittakaavassa, mitä vain tällä palstalla. Mistä tuo ilmiö nyt oikein johtuu, ja saa alkuvoimansa?3091634Odotan sitä hetkeä
kun nähdään taas. Tiedän, että sinäkin odotat. Kun se päivä koittaa, katseesi hakee minua. Ehkä arkailemme toisiamme väh751234Olen melko vakuuttunut
etten tule olemaan koskaan täysin onnellinen ilman sinua. En uskonut, että näin kävisi kenenkään kanssa. Kunnes sain kok801167Jenkkilahkojen kastekaava
Jenkkilahkojen yhteinen kastekaava on kirjoitettuna Mormonin Kirjaan, Moroni, luku-8 Pienten lapsien vanhempia uhataan1391124- 1321102
Pasi Turunen: Ensimmäisenä Helluntaina ei kastettu sylivauvoja!
Tänään 31.5.2026 Pasi Turunen noin vastasi soittajan kysymykseen! Raamattu EI KERRO ketä kastettiin1611095- 1711074
- 49944