summan tekijöiden etsiminen

bufguhgf

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.

9

141

Äänestä

    Vastaukset 9

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • 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ää.

    • kunde

      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

    • 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

      • 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

      • 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ä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Uskallanko laittaa sulle viestiä?

      Se viesti on tossa valmiina ja lähettämistä vaille valmis. Kun ei kauhee sti tunneta niin eipä sillä olisi niin väliä. S
      Ikävä
      58
      800

    2. Mikä tekee kaivatustasi

      Haluttavan?
      Ikävä
      34
      785

    3. Mies joka on oikeasti kiinnostunut

      Ja näkee sut pitkäaikaisena kumppanina, siirtää vaikka vuoria selvittääkseen asiat eikä ota pienintäkään riskiä menettää
      Ikävä
      125
      736

    4. Onko nyt kaikki asiat käyty läpi?

      Mun mielestä on👍
      Ikävä
      88
      663

    5. Vieläkin saat

      Sydämen tykyttämään. Vaikka emme näe
      Ikävä
      28
      580

    6. En tahallaan sua välttele...

      Olis niin kiva nähdä jossain muualla kuin kaupassa!
      Ikävä
      40
      537

    7. Rauha, sopiiko

      Ei häiritä enää toisiamme. Annetaan molemmille rauha unohtaa, pyydän tätä todella. Kiitos. Miehelle.
      Ikävä
      71
      496

    8. Lehtikankaan oppilas kuolema

      Mistä lie tyttöparka löytyny, mikä ajaa tekemään itsemurhan tuon ikäsenä 😞
      Kajaani
      9
      492

    9. Ei siitä pääse yli, eikä ympäri!

      Pakko se on myöntää ja tunnustaa. Olisin halunnut p*nna sinua sydämeni kyllyydestä. Itseäni vanhemmalle naiselle
      Ikävä
      63
      489

    10. Ikävä niitä hetkiä,kun katselin sua suoraan silmiin...

      😊
      Ikävä
      40
      464

    11. Pystyisitkö liikkumaan

      Tai tapailemaan kaivattuasi julkisesti?
      Ikävä
      45
      426

    12. Kumpi tästä nyt

      Teki niin vaikeaa?
      Ikävä
      57
      419

    13. Nyt kaatuu Kuisla

      Reima Kuisla hakee saneeraukseen – Joitakin velkoja on jo ulosotossa https://www.ilkkapohjalainen.fi/reima-kuisla-hakee
      Seinäjoki
      24
      410

    14. Kunnanhallitus

      Miten käy täällä vuosia tuomioita jakaneelle valittajalle, hovioikeus hylännyt kaikki syytteet.
      Puolanka
      23
      398

    15. Emme pääse koskaan

      Tästä. Sinä et suostu enkä minä suostu
      Ikävä
      38
      394

    16. Olit hyödytön.

      Mulle hyödytön..
      Ikävä
      72
      393

    17. Mikä estää ottamasta yhteyttä?

      🤨
      Ikävä
      39
      393

    18. Minkä kappaleen

      haluaisit soivan, kun astellaan alttarille?
      Ikävä
      33
      391

    19. Vieläkö tykkäät

      Minusta niin paljon että olisit valmis?
      Ikävä
      35
      387

    20. Ylen suosikkisarja tuotti pettymyksen - Loppuiko Ellis tv-sarja todella tähän?

      Nyt Suomessa on nähty tv-sarjan kaksi ensimmäistä kautta. Toisella kaudella tiedossa oli tv-katsojille ikävä yllätys,
      Tv-sarjat
      0
      386
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt