29. august 2007 - 22:10Der 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.
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.
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
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
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
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 ;-)
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
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.
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:
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.
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 :)
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
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 :)
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.
Synes godt om
Ny brugerNybegynder
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.