Vergelijk data, maak opgave met verschillen, kleur cellen die afwijken

Status
Niet open voor verdere reacties.
H

Hela1966

Gebruiker
Lid geworden
17 jan 2009
Berichten
54
Dag experts,

Voor het vergelijken van 2 lijsten gebruikte ik altijd deze code.
Dat werkte prima omdat beide lijsten hetzelfde aantal regels en ID's hadden.

Code: 
Sub ColorChanges()

Dim wsO, wsN, wsC As Worksheet
Dim rngCell As Range
 
Set wsO = Sheet1
Set wsN = Sheet2
For Each rngCell In wsN.UsedRange
    If Not rngCell = wsO.Cells(rngCell.Row, rngCell.Column) Then
        rngCell.Interior.Color = vbYellow
    End If   
Next rngCell

End Sub

Door een interne wijziging komt het nu voor dat de lijsten minder of meer regels bevatten.
(het aantal en de titels van de kolommen is op beide lijsten identiek)

Ik wil graag de code aanpassen waardoor ik op sheet3 een opgave krijg van
enkel die ID's die op beide lijsten voorkomen maar enkel als de data in 1 van de cellen ernaast afwijkt.
Die cel (of cellen) in die row dan geel kleuren.

Ik heb een voorbeeldje gemaakt in bijgaande file.

Hopelijk kan iemand me hiermee helpen.
Alvast dank voor de te nemen moeite.
 

Bijlagen

  • Test Compare vba.xlsm
    28,2 KB · Weergaven: 32
Voorwaardelijke opmaak en een formule om te filteren is ook een optie. Geen onbegrijpelijke VBA voor nodig.
 

Bijlagen

  • Test Compare vba.xlsm
    23,4 KB · Weergaven: 25
Iets minder eenvoudig dan je zou hopen:

Code: 
Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
  sp = Sheet2.Cells(1).CurrentRegion
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = Application.Index(sn, j)
    Next
        
    For j = 2 To UBound(sp)
      st = .Item(sp(j, 1))
      sp(j, 1) = ""
      For jj = 2 To UBound(st)
        If sp(j, jj) <> st(jj) Then
          sp(j, jj) = sp(j, jj) & "_"
          sp(j, 1) = st(1)
        End If
      Next
    Next
        
    Sheet3.Cells(1).Resize(UBound(sp), UBound(sp, 2)) = sp
    Sheet3.UsedRange.Columns(1).SpecialCells(4).EntireRow.Delete
        
    For Each it In Sheet3.UsedRange
      If Right(it, 1) = "_" Then it.Interior.Color = vbYellow
      it.Replace "_", ""
    Next
  End With
End Sub
 
VenA zei:
Voorwaardelijke opmaak en een formule om te filteren is ook een optie. Geen onbegrijpelijke VBA voor nodig.
Klik om te vergroten...

Dag VenA, dank je.
Ja ik gebruik ook zoveel mogelijk formules en filtering maar in dit geval (lees voor deze gebruikers) lijkt het me beter VBA te gebruiken.
 
snb zei:
Iets minder eenvoudig dan je zou hopen:

Code: 
Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
  sp = Sheet2.Cells(1).CurrentRegion
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = Application.Index(sn, j)
    Next
        
    For j = 2 To UBound(sp)
      st = .Item(sp(j, 1))
      sp(j, 1) = ""
      For jj = 2 To UBound(st)
        If sp(j, jj) <> st(jj) Then
          sp(j, jj) = sp(j, jj) & "_"
          sp(j, 1) = st(1)
        End If
      Next
    Next
        
    Sheet3.Cells(1).Resize(UBound(sp), UBound(sp, 2)) = sp
    Sheet3.UsedRange.Columns(1).SpecialCells(4).EntireRow.Delete
        
    For Each it In Sheet3.UsedRange
      If Right(it, 1) = "_" Then it.Interior.Color = vbYellow
      it.Replace "_", ""
    Next
  End With
End Sub
Klik om te vergroten...


Hoi SNB! Uw code maakt dat ik echt even moet turen naar wat het precies zal doen.
Ik vermoed dat ik dat beter morgenvroeg kan doen ;-)
Alvast dank, ik laat u weten of het me is gelukt!
 
@hela: leg eens uit waarom je complete berichten denkt te moeten quoten?
 
Ooh excuses OctaFish, dat was niet mijn bedoeling.
Ik schrok even van de gebiedende wijze van uw vraagstelling.
Wou enkel reageren en heb de verkeerde knop gebruikt vermoed ik.
Geen opzet hoor. Ik zal er voortaan op letten.
 
Heel goed :). Ik was wat strenger omdat je al sinds 2009 lid bent.
 
Hoi SNB! Uw code maakt dat ik echt even moet turen naar wat het precies zal doen.
Klik om te vergroten...
Vandaar ook de suggestie om het met een paar eenvoudige formules op te lossen. Turen naar codes is niet de beste manier om te analyseren wat er gebeurt.:d
 
Deze is wel wat simpeler

Code: 
Sub jvv()
 With Application
   Sheets(2).Cells(1, 1).CurrentRegion.Copy Sheets(3).Cells(1, 1)
   Set jv = Sheets(3).Cells(1).CurrentRegion
   Set ar = Sheets(1).Cells(1).CurrentRegion
   Set ar2 = Sheets(3).Cells(1, 99)
   
   For i = jv.Rows.Count To 2 Step -1
      For Each cl In jv.Rows(i).Cells
          If Not IsNumeric(.Match(cl, ar.Rows(.Match(jv.Cells(i, 1), ar.Columns(1), 0)), 0)) Then
            Set ar2 = Union(ar2, cl)
            a = a + 1
          End If
      Next
     If a = 0 Then jv.Rows(i).Delete
     a = 0
   Next
   
  ar2.Interior.ColorIndex = 6
 End With
End Sub
 
@VenA

Vergeleken met vele anderen die niet eens beginnen aan turen...... ;)
Ik beschouw ieder turen als een begin.
En Hela weet tegen wie ze het zegt.
 
Het is inmiddels al middag!

Ik heb eens flink de tijd genomen om te "turen" naar beide oplossingen. Wat goed gedaan weer door jullie.

Toen ik vrijdag zelf (ja ja, ik puzzel ECHT eerst een hele tijd voordat ik een vraag stel op het forum) met de code aan de slag ging
had ik ook een poging gedaan om eerst alles te kopiëren naar sheet3 en vervolgens eruit te vissen wat niet gewenst was.
Maar dat lukte me niet goed.

Toen ook een halve slag geslagen met index en match (in formules ben ik daar dol op) maar dat draaide ook in de soep.

Dus nu wel leuk om te zien dat beide elementen in jullie codes terugkomen.
Waar ik nooooooit aan gedacht had was het toevoegen van _ zoals in de code van SNB.
Heel slim!
Om het “turen” makkelijker te maken voor mezelf heb ik alle gedeclareerde variabelen vertaald naar een, voor mij, leesbaar begrip.
Dan zoeft de code gewoon wat beter door m’n hoofd. Daarna zoveel mogelijk stap voor stap gekeken (soms met debug.print) wat de code deed.
Dat werkt het best voor mij. Niet dat ik de illusie heb dat ik zoiets over 2 maanden zonder spieken uit m’n mouw kan schudden
maar door goed te lezen blijft het toch ergens hangen en probeer ik het een volgende keer zelf uit te vogelen.
Dank daarvoor.

Daarna de code van JVeer. Dat was inderdaad iets makkelijker om te lezen.
En daar kwam mijn grote-vriend Match weer bij kijken! Ook een prima benadering.
In het geval ik het aantal kolommen van een sheet vooraf niet weet zou ik de laatste natuurlijk kunnen vinden column.count en die met een paar verhogen voor ar2.
Het Step To principe ken ik wel maar gebruik ik eigenlijk weinig. Best jammer, want het werkt prima en soms is die benadering van data precies goed.
Al met al ook een hele solide oplossing voor mijn vraag. Pet af en hartelijk dank!

Bij nader inzien hoef ik geen echte keuze te maken tussen de code van SNB of JVeer.
Voor kleinere datasets zal ik de code van JVeer gebruiken maar voor een grotere dataset (soms 7000 rijen en over de 80 kolommen) die van SNB.
Best of both worlds!

Ik hoop niet dat jullie het erg vinden dat ik zo uitgebreid reageer, maar vind het belangrijk te laten zien dat ik jullie moeite echt waardeer en niet klakkeloos de code copy/paste.
Mijn leercurvee is bijna zo plat als een dubbeltje maar er is een leercurve!

Nogmaals mijn oprechte dank.

Gr,

Hela

PS: ja SNB, good old times!
 
Na enig 'turen' op jouw formule in F2 kwam ik op deze niet-arrray formule:

PHP: 
=SUMPRODUCT(N(OldData!$A$1:$A$7&OldData!$B$1:$B$7&OldData!$C$1:$C$7&OldData!$D$1:$D$7&OldData!$E$1:$E$7=A2&B2&C2&D2&E2))
 
Niet naar getuurd alleen laten evalueren en het scheelt inderdaad een aantal stapjes.:)
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan