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
122
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
Vuonna 2026 jää entistä vähemmän rahaa käteen palkansaajille
Työttömyysvakuutusmaksu nousee 0,3 prosenttia. Työeläkemaksu nousee 7,15 prosentista 7,3 prosenttiin. Työmarkkinajärjest1056913Suomen kansa puhunut: Purra huonoimpia ministereitä
Kouluarvosanalla 6–, eli samaa tasoa mitä Purran oikeakin koulutodistus. Epäpätevyys on tullut huomattua Suomen talouden4835045Mitä aiot tehdä uudenvuoden aattona
Mitä olet suunnitellut tekeväsi uudenvuoden aattona ja aiotko ensi vuonna tehdä jotain muutoksia tai uudenvuoden lupauks1302989Joulun ruokajonoissa entistä enemmän avuntarvitsijoita - Mitä ajatuksia tämä herättää?
Räppärit Mikael Gabriel, VilleGalle ja Jare Brand jakoivat ruokaa ja pehmeitäkin paketteja vähävaraisille jouluaattoa ed1772518Marin sitä, Marin tätä, yhyy yhyy, persut jaksaa vollottaa
On nuo persut kyllä surkeaa porukkaa. Edelleen itkevät jonkun Marinin perään, vaikka itse ovat tuhonneet Suomen kansan t182226Pituuden mittaaminen
Ihmisen pituuden mittaaminen ja puolikkaat senttimetrit. Kuuluuko ne puolikkaatkin sentit tai millit teistä ilmoittaa m361214En tiedä enää
Pitäiskö mun koittaa vältellä sua vai mitä? Oon välillä ollut hieman mustasukkainen, myönnän. En ymmärrä miksi en saa su721143Muistattekos kuinka persujen Salainen Akentti kävi Putinin leirillä
Hakemassa jamesbondimaista vakoiluoppia paikan päällä Venäjällä? Siitä ei edes Suomea suojeleva viranomainen saanut puhu51090Luuletko, että löydetään vielä
Yhteys takaisin? En tiedä enää mitä tehdä... tuntuu jo että olen vieraantunut sinusta. Naiselta531060- 1071054