VBA - Match sum med enkelt celle

Hvor mange tal er der i kolonne A, og hvordan vil du have markeret med farver, hvis et tal kan gå igen flere gange?

OK, prøv denne

Du skal klikke ind på det tal i A kolonnen, den skal finde, koden stopper ved første match, så kikker den ikke efter mere, hvis den skal, så sig til.

Sub Makro1()
    Dim Data As Variant, Valgt As Integer
    Dim A As Integer, B As Integer
    Dim F As Variant
    Dim Cadresse As String, MinSum As Integer
    Range(Range("A1"), Range("B65536").End(xlUp)).Interior.ColorIndex = xlNone
    Data = Range(Range("A1"), Range("B65536").End(xlUp))
    Valgt = ActiveCell.Value
    A = UBound(Data)

    For i = 1 To A
        MinSum = Data(i, 2)
        Cadresse = i
        For B = 1 To A
            If B <> i Then
                If MinSum + Data(B, 2) <= Valgt Then
                    Cadresse = Cadresse & ";" & B
                    MinSum = MinSum + Data(B, 2)
                    If MinSum = Valgt Then GoTo Færdig
                Else
                    MinSum = Data(i, 2)
                    Cadresse = i

                End If
            End If
        Next
        Cadresse = ""
        MinSum = 0
    Next
    Exit Sub
Færdig:
    F = Split(Cadresse, ";")
    For i = 0 To UBound(F)
        Cells(F(i), 2).Interior.ColorIndex = 6
    Next
End Sub

kabbak: Sidder med noget der ligner dit meget, men der skal være op til 10 værdier der kan matche.

mener du sum af 10 tal, det skulle den kunne gøre, men jeg mener at når den har fundet en sum der passer, så stopper den.

Jeg er heller ikke helt med, da han skriver at det skal kunne være helt op til 10 tal, der kan matche resultatet. Med så mange tal, kan der være utallige muligheder.

Ok jeg har arbejdet videre, koden genbruger ikke tal der er brugt, men kikker videre efter andre kombinationer, hver kombination får sin egen farve.

Prøv at tjekke

Sub Makro1()
    Dim Data As Variant, Valgt As Integer
    Dim A As Integer, B As Integer, Farve As Integer
    Dim F As Variant, Fundet As Boolean, X As Integer
    Dim Cadresse As String, MinSum As Integer, TotalAdresse As String
    Range(Range("A1"), Range("B65536").End(xlUp)).Interior.ColorIndex = xlNone
    Data = Range(Range("A1"), Range("B65536").End(xlUp))
    Valgt = ActiveCell.Value
    A = UBound(Data)
    Fundet = False
    X = 2
    TotalAdresse = "*"
    For i = 1 To A

        MinSum = Data(i, 2)
        If Fundet Then TotalAdresse = TotalAdresse & Cadresse & ";*"
        Cadresse = ";" & i
        For B = 1 To A
            If B <> i Then
                If Not InStr(1, TotalAdresse, ";" & B & ";") > 0 Then
                    If MinSum + Data(B, 2) <= Valgt Then
                        Cadresse = Cadresse & ";" & B
                        MinSum = MinSum + Data(B, 2)
                        If MinSum = Valgt Then
                            Fundet = True
                            Exit For
                        End If
                    Else
                        MinSum = Data(i, 2)
                        Cadresse = ";" & i
                        Fundet = False
                    End If
                End If
            End If
        Next
    Next
    If InStr(1, TotalAdresse, ";") > 0 Then
        Farve = 2
        F = Split(TotalAdresse, ";")
        For i = 0 To UBound(F)
            If F(i) = "*" Then
                Farve = Farve + 1
            Else
                Cells(F(i), 2).Interior.ColorIndex = Farve
            End If
        Next
    End If
End Sub

der var lige en rettelse

Sub Makro1()
    Dim Data As Variant, Valgt As Integer
    Dim A As Integer, B As Integer, Farve As Integer
    Dim F As Variant, Fundet As Boolean, X As Integer
    Dim Cadresse As String, MinSum As Integer, TotalAdresse As String
    Range(Range("A1"), Range("B65536").End(xlUp)).Interior.ColorIndex = xlNone
    Data = Range(Range("A1"), Range("B65536").End(xlUp))
    Valgt = ActiveCell.Value
    A = UBound(Data)
    Fundet = False
    X = 2
    TotalAdresse = "*"
    For i = 1 To A
If Not InStr(1, TotalAdresse, ";" & i & ";") > 0 Then
        MinSum = Data(i, 2)
        If Fundet Then TotalAdresse = TotalAdresse & Cadresse & ";*"
        Cadresse = ";" & i
        For B = 1 To A
            If B <> i Then
                If Not InStr(1, TotalAdresse, ";" & B & ";") > 0 Then
                    If MinSum + Data(B, 2) <= Valgt Then
                        Cadresse = Cadresse & ";" & B
                        MinSum = MinSum + Data(B, 2)
                        If MinSum = Valgt Then
                            Fundet = True
                            Exit For
                        End If
                    Else
                        MinSum = Data(i, 2)
                        Cadresse = ";" & i
                        Fundet = False
                    End If
                End If
            End If
        Next
        End If
    Next
    If InStr(1, TotalAdresse, ";") > 0 Then
        Farve = 2
        F = Split(TotalAdresse, ";")
        For i = 0 To UBound(F)
            If F(i) = "*" Then
                Farve = Farve + 1
            Else
                Cells(F(i), 2).Interior.ColorIndex = Farve
            End If
        Next
    End If
End Sub

Ok, jeg tror vi tolker spørgsmålet forskelligt.

Hvis man har værdien 40 i A1 og tallene 1 til 20 i B1 til B20, giver det med min kode 401 forskellige kombinationer. Det er lidt svært at farvelægge ;-)

prisoner_97p904: Hvad er meningen?

Jeg tolker det sådan at hvis han markerer  77 i A kolonnen, så skal den finde de tal der er eller kan summeres op til 77, jeg har nu lavet så den vælger dem der passer, men ingen af værdierne kan gå igen, hvis de er brugt i en anden summering.

her er ny kode, den gamle kunne ikke vælge dem der passede direkte.

Sub Makro1()
    Dim Data As Variant, Valgt As Integer
    Dim A As Integer, B As Integer, Farve As Integer
    Dim F As Variant, Fundet As Boolean, X As Integer
    Dim Cadresse As String, MinSum As Integer, TotalAdresse As String
    Range(Range("A1"), Range("B65536").End(xlUp)).Interior.ColorIndex = xlNone
    Data = Range(Range("A1"), Range("B65536").End(xlUp))
    Valgt = ActiveCell.Value
    A = UBound(Data)
    Fundet = False
    X = 2
    TotalAdresse = "*"
    For i = 1 To A
If Not InStr(1, TotalAdresse, ";" & i & ";") > 0 Then
        MinSum = Data(i, 2)
        If Data(i, 2) = Valgt Then
        Fundet = True
        Cadresse = ";" & i
        TotalAdresse = TotalAdresse & Cadresse & ";*"
        GoTo Videre
        End If
        If Fundet Then TotalAdresse = TotalAdresse & Cadresse & ";*"
     
                For B = 1 To A
           
            If B <> i Then
                If Not InStr(1, TotalAdresse, ";" & B & ";") > 0 Then
                    If MinSum + Data(B, 2) <= Valgt Then
                        Cadresse = Cadresse & ";" & B
                        MinSum = MinSum + Data(B, 2)
                        If MinSum = Valgt Then
                            Fundet = True
                            Exit For
                        End If
                    Else
                        MinSum = Data(i, 2)
                        Cadresse = ";" & i
                        Fundet = False
                    End If
                End If
                End If
           
        Next
Videre:
        End If
    Next
    If InStr(1, TotalAdresse, ";") > 0 Then
        Farve = 2
        F = Split(TotalAdresse, ";")
        For i = 0 To UBound(F)
            If F(i) = "*" Then
                Farve = Farve + 1
            Else
                Cells(F(i), 2).Interior.ColorIndex = Farve
            End If
        Next
    End If
    Debug.Print TotalAdresse
End Sub


jeg går i seng nu, men jeg kikker på igen en gang i morgem :o

Hej.

Først: tak for svarene :)

Der skal bare findes første match ved hvert tal fra A-rækken, så hvis man har:
10, 20, 30 i A
og
5,5,5,5,5,5,5,5,5,5,5,5
vil de første 2 5'ere blive matchet til 10'eren og 3. til 6. 5'er vil blive matchet til 20'eren og så vil de sidste 6 5'ere blive matchet til 30'eren.

Begrænsningen på 10 er for at der ikke vil være alt for mange sammenligninger, men kan godt se at der vil komme enormt mange sammenligninger, hvis rækkerne bliver på eks. 100 * 50, eller mere!

Begrænsningen på 10 vil f.eks. gøre at den ikke matcher:
14, 15, 52, 77 i A
og
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1.
Her vil/skal ikke være nogen matches.

Ok, så er det kabbaks kode du skal bruge.

Hvis jeg kører kabbak's kode, så får jeg en fejl. Jeg har prøvet at taste nogle tal ind fra A1 til A23 og B1 til B14, og når jeg prøver at køre makroen, så får jeg:

Run-time error '6'
Overflow

På linjen med:
        MinSum = Data(i, 2)

Er det mig der har lavet en fejl?

hvis du kører med store tal, så skal
  Dim Cadresse As String, MinSum As Integer, TotalAdresse As String

den tager kun heltal, ikke decimaler

  Dim Cadresse As String, MinSum As Long, TotalAdresse As String

Jeg prøvede lige med
45    1
46    2
47    3
48    4
49    5
50    6
51    7
52    8
53    9
54    10
55    11
56    12
Og der var ingen fejl, så det var nok pga. de store tal før.
Men når jeg så kører macroen, så farver den 1,3,5,7,8 i 3 forskellige farver, og de giver ikke nogen af de tal i A-rækken.

Det jeg ville have var at dette tilfælde skulle 45 blive farvet f.eks. rød og så ville tallene 1 til 9 også blive farvet røde, da de giver 45. Da de resterende tal (10, 11 og 12) ikke giver noget af det i A-rækken, vil andre ikke blive farvet. Hvis der så istedet var andre tal, der gav et tal i a-rækken ville de blive farvet f.eks. blå.

Nu kørte jeg den igen, og så blev alle i B-rækken farvet grønne, ved ikke om jeg har lavet noget forkert igen, men der er ingen fejl i koden, der gør den stopper

Koden er lavet sådan at du klikker ind på den celle i A kolonnen, der har den værdi den skal finde summen for,  kør så derefter makroen.
I øjeblikket, bliver cellen i A kolonnen ikke farvet.

Jeg kan se at der er problemer, med koden, jeg testede på det tal, der var i spørgsmålet, og da gik det godt, jeg kikker videre i aften.

Okay, det er rigtig fint at den tager den celle man selv vælger.
Det med cellen ikke bliver farvet er ikke noget problem da det er den celle der er markeret, så ved man hvor den matcher . Takker :)

prøv at teste denne:

Sub Makro1()
    Dim Data As Variant, Valgt As Integer
    Dim A As Integer, B As Integer, Farve As Integer
    Dim F As Variant, Fundet As Boolean, T As Integer
    Dim Cadresse As String, MinSum As Long, TotalAdresse As String
    Range(Range("A1"), Range("B65536").End(xlUp)).Interior.ColorIndex = xlNone
    Data = Range(Range("A1"), Range("B65536").End(xlUp))
    Valgt = ActiveCell.Value
    A = UBound(Data)
    Fundet = False
    TotalAdresse = "*"

        For i = 1 To A
            If InStr(1, TotalAdresse, ";" & i & ";") = 0 Then ' tjekket om cellen er brugt

                If Data(i, 2) = Valgt Then    ' hvis værdien passer på 1 celle
                    Fundet = True
                    Cadresse = ";" & i
                    GoTo Videre
                ElseIf Data(i, 2) > Valgt Then    ' hvis værdien er større end første celle
                    Fundet = False
                    GoTo Videre
                End If

                MinSum = Data(i, 2)    ' sætte første værdi ind
                Fundet = False
                Cadresse = ";" & i ' sætter startcelle ind
                For B = 1 To A
                    If B <> i Then
                        If InStr(1, TotalAdresse, ";" & B & ";") = 0 Then ' tjekket om cellen er brugt
                            If MinSum + Data(B, 2) <= Valgt Then
                                Cadresse = Cadresse & ";" & B
                                MinSum = MinSum + Data(B, 2)
                                If MinSum = Valgt Then
                                    Fundet = True
                                    Exit For
                                End If
                                Else
                                MinSum = Data(i, 2)
                                Cadresse = ";" & i
                            End If
                        End If
                    End If
                Next
            Else
                Fundet = False
            End If
Videre:
            If Fundet Then TotalAdresse = TotalAdresse & Cadresse & ";*"
        Next

    If InStr(1, TotalAdresse, ";") > 0 Then
        Farve = 2
        F = Split(TotalAdresse, ";")
        For i = 0 To UBound(F)
            If F(i) = "*" Then
                Farve = Farve + 1
            Else
                Cells(F(i), 2).Interior.ColorIndex = Farve
            End If
        Next
    End If
End Sub

SUPER!

Den virker bedre end jeg havde håbet på! Den finder alle matches, så hvis jeg har 190 i A-rækken, så finder den f.eks. 180+10 & 170+20 & 100+90 i B-rækken :)

Mange tak!

håber du er tilfreds, jeg undres bare over, hvad det skal bruges til ??

og et svar ;-))

hilsen kabbak

Det er pga. jeg har to ark hvor der er matchende beløb i hver, der skal udlignes, og så er der nogle gange at beløbene ikke passer overens, hvor de er blevet delt op i 2, 3 eller mange flere småbeløb, så skal de findes.

Da det ikke er helt så sikkert at slette de beløb der "måske" stemmer overens i det andet ark farves de bare, så jeg selv kan tjekke om de er korrekte og så slette dem efterfølgende.