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

110

    Vastaukset

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


    • 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


      • 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

    1. Hengenvaaralliset kiihdytysajot päättyivät karmealla tavalla, kilpailija kuoli

      Onnettomuudesta on aloitettu selvitys. Tapahtuma keskeytettiin onnettomuuteen. Tapahtumaa tutkitaan paikan päällä yhtei
      Kauhava
      192
      6756
    2. Ootko rakastunut?

      Kerro pois nyt
      Ikävä
      156
      1965
    3. Onhan sulla nainen parempi mieli

      Nyt? Ainakin toivon niin.
      Ikävä
      113
      1658
    4. Ujosteletko tosissaan vai mitä oikeen

      Himmailet???? Mitä pelkäät?????
      Ikävä
      51
      1370
    5. Suureksi onneksesi on myönnettävä

      Että olen nyt sitten mennyt rakastumaan sinuun. Ei tässä mitään, olen kärsivällinen ❤️
      Ikävä
      53
      1169
    6. Mö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! 😢
      Kauhava
      42
      1051
    7. Ä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 hu
      Ikävä
      99
      1015
    8. Reeniähororeeniä

      Helvetillisen vaikeaa työskennellä hoitajana,kun ei kestä silmissään yhtään läskiä. Saati hoitaa sellaista. Mitä tehdä?
      Kouvola
      6
      947
    9. Tarvitsemme lisää maahanmuuttoa.

      Väestö eläköityy, eli tarvitsemme lisää tekeviä käsiä ja veronmaksajia. Ainut ratkaisu löytyy maahanmuutosta. Nimenomaan
      Maailman menoa
      249
      918
    10. Kävit nainen näemmä mun

      Facessa katsomassa....
      Ikävä
      41
      889
    Aihe