Avatar billede prisoner_97p904 Nybegynder
29. august 2007 - 22:10 Der er 22 kommentarer og
1 løsning

VBA - Match sum med enkelt celle

Hej!

Jeg sidder og leger med noget VBA i Excel, og prøver at få løst følgende problem:
Jeg har to rækker med værdier, og jeg vil gerne finde alle de værdier i række B der svarer til én værdi i række A.

Dvs. at der er en værdi i række A der svarer til 2, 3, 4, 5... eller op til 10 forskellige værdier i række B, og det skal gerne blive markeret med en farve.

-------------
| 37  | 12* |
-------------
| 52  | 22* |
-------------
| 77* | 79  |
-------------
| 33  | 43* |
-------------
| 99  | 108 |
-------------

Jeg har prøvet på at illustrere det her, hvor 77 passer med 12+22+43, så derfor er der blevet tilføjet en stjerne ved alle 4 steder.

Jeg har tænkt på om kørertiden af algoritmen bliver meget høj da der kan komme mange sammenligninger, men det håber jeg på at I kan hjælpe mig med, eller har et smart alternativ.
Avatar billede gider_ikke_mere Nybegynder
29. august 2007 - 22:30 #1
Hvor mange tal er der i kolonne A, og hvordan vil du have markeret med farver, hvis et tal kan gå igen flere gange?
Avatar billede kabbak Professor
29. august 2007 - 23:59 #2
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
Avatar billede gider_ikke_mere Nybegynder
30. august 2007 - 00:09 #3
kabbak: Sidder med noget der ligner dit meget, men der skal være op til 10 værdier der kan matche.
Avatar billede kabbak Professor
30. august 2007 - 00:28 #4
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.
Avatar billede gider_ikke_mere Nybegynder
30. august 2007 - 00:34 #5
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.
Avatar billede kabbak Professor
30. august 2007 - 00:47 #6
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
Avatar billede kabbak Professor
30. august 2007 - 00:55 #7
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
Avatar billede gider_ikke_mere Nybegynder
30. august 2007 - 01:02 #8
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?
Avatar billede kabbak Professor
30. august 2007 - 01:11 #9
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
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 08:20 #10
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!
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 08:22 #11
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.
Avatar billede gider_ikke_mere Nybegynder
30. august 2007 - 10:34 #12
Ok, så er det kabbaks kode du skal bruge.
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 10:51 #13
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?
Avatar billede kabbak Professor
30. august 2007 - 12:06 #14
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
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 12:25 #15
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å.
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 12:28 #16
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
Avatar billede kabbak Professor
30. august 2007 - 12:30 #17
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.
Avatar billede kabbak Professor
30. august 2007 - 12:38 #18
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.
Avatar billede prisoner_97p904 Nybegynder
30. august 2007 - 13:14 #19
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 :)
Avatar billede kabbak Professor
30. august 2007 - 23:13 #20
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
Avatar billede prisoner_97p904 Nybegynder
31. august 2007 - 11:37 #21
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!
Avatar billede kabbak Professor
31. august 2007 - 11:54 #22
håber du er tilfreds, jeg undres bare over, hvad det skal bruges til ??

og et svar ;-))

hilsen kabbak
Avatar billede prisoner_97p904 Nybegynder
02. september 2007 - 17:43 #23
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.
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester