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
104
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
Moikka rakas
Oon miettinyt meidän välistä yhteyttä viime aikoina. En ihan osaa pukea sanoiksi, mitä kaikkea tunnen, mutta halusin vaa3410735Malmin tapaus on järkyttävä
Kolme ulkomaalaistaustaista miestä raiskasi nuoren tytön tavalla, jota ei meinaa uskoa todeksi. Mikä voisi olla oikeampi6182976- 1522073
HS: Kuka vielä uskaltaa mennä sairaalan ensiapuun?
https://www.hs.fi/mielipide/art-2000011212025.html Tässä on hyvin ajankohtainen mielipidekirjoitus koskien Malmin sairaa1661686- 1051509
Ökyrikas Kurkilahti mussuttaa veroistaan
Pakeni aikoinaan veroja Portugaliin mutta joutui palaamaan takaisin kun Suomi teki verotussopimuksen Portugalin kanssa.1091272- 751137
Yhdysvalloissa työllisyys paranee, Suomessa työttömyys kasvaa, missä vika?
Miten tämä on mahdollista että 177 000 uutta työllistä tuli USAssa yhdessä kuukaudessa, vaikka Trump on ruorissa? Orpon2631111Jos tämän vaan sulkee ja avaa 5 vuoden päästä
Täällä on luultavasti edelleen näitä ihan samoja juttuja. On kuin kauniit ja rohkeat samat jutut junnaa. Heips. 👋🏻 E101043- 371034