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.
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.
Vastaukset 9
Vanhimmat
Montako lukua maksimissaan ja montako lukua saa maksimissaan käyttää?
Vaikuttaa oleellisesti ongelman ratkaisun vaikeusasteeseen.
Keep EXCELing
@Kunde
ja haluatko vielä kaikki variaatiot vai ekaksi löydetyn? Sekin vaikuttaa... ;-)
Satoja lukuja. Ehkä noin 300 voisi olla käytännössä maksimi. En tarvitse kaikkia variaatioita, vaan nimenomaan riittää yksi.
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
@Kunde
jä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
Wau! Toimii. Näköjään tuolla ohjelmalla voi tehdä melkein mitä vaan. Suuret kiitokset.
hyvä, että oli toiveiden mukainen.
VBA kyllä taipuu Excelissä melko monimutkaisiin juttuihin ;-)
Keep EXCELing
@Kunde