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
110
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
Hengenvaaralliset kiihdytysajot päättyivät karmealla tavalla, kilpailija kuoli
Onnettomuudesta on aloitettu selvitys. Tapahtuma keskeytettiin onnettomuuteen. Tapahtumaa tutkitaan paikan päällä yhtei1756471- 1481784
- 1131558
- 511300
Suureksi onneksesi on myönnettävä
Että olen nyt sitten mennyt rakastumaan sinuun. Ei tässä mitään, olen kärsivällinen ❤️46982Möykkähulluus vaati kuolonuhrin
Nuori elämä menettiin täysin turhaan tällä järjettömyydellä! Toivottavasti näitä ei enää koskaan nähdä Kauhavalla! 😢37938Älä mies pidä mua pettäjänä
En petä ketään. Älä mies ajattele niin. Anteeksi että ihastuin suhun varattuna. Pettänyt en ole koskaan ketään vaikka hu97901Reeniähororeeniä
Helvetillisen vaikeaa työskennellä hoitajana,kun ei kestä silmissään yhtään läskiä. Saati hoitaa sellaista. Mitä tehdä?5849Tarvitsemme lisää maahanmuuttoa.
Väestö eläköityy, eli tarvitsemme lisää tekeviä käsiä ja veronmaksajia. Ainut ratkaisu löytyy maahanmuutosta. Nimenomaan235804- 41799