vereenvoudigen van bestaande code welke waardes vergelijkt

Status
Niet open voor verdere reacties.
H

Hela1966

Gebruiker
Lid geworden
17 jan 2009
Berichten
54
Dag Experts,

Ik heb een stukje code in VBA wat op zich functioneert (aangeven van verschillen tussen 2 cellen).

Dit is een voorbeeldje:
CompList.jpg

Dit is wat ik probeer te bereiken:
Van alle ID's vergelijken of de waardes in lijst Controle gelijk zijn aan Lijst Boekingen.

- Speciale leestekens in lijst Boekingen moeten genegeerd worden
- Verschillen in hoofdletters moeten genegeerd worden.

Daarna:
Als waarde in lijst Controle niet gelijk is aan Lijst Boekingen dan de waarde van cel Controle geel kleuren.

Waardes in List A of List B niet aanpassen.

En dit is mijn huidige code:

Code: 
Sub Repl_Comp_HighLight()

Const Accent = "àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ'‘’"
Const Normal = "aaaaaaceeeeiiiidnooooouuuuyySZszYAAAAAACEEEEIIIIDNOOOOOUUUUY   "

Set ws = Sheet1
Set rng = ws.Range("A2:A10")
    
ws.Range("C2:C10").Interior.Pattern = xlNone

For Each cell In Range("B2:B10")
       tmp = cell.Value
        
            For x = 1 To Len(Accent)
                tmp = Replace(tmp, Mid(Accent, x, 1), Mid(Normal, x, 1))
            Next
        cell.Offset(0, 2).Value = tmp
    Next

With ws
    For Each cell In .Range(rng.Address)
             myComp = StrComp(cell.Offset(0, 3), cell.Offset(0, 2), vbTextCompare)
        If myComp <> 0 Then cell.Offset(0, 2).Interior.Color = vbYellow
    Next
End With

ws.Columns(4).Delete

End Sub

De stap "cell.offset(0,2).value = temp" zou ik graag "overslaan" zodat er geen data naar het sheet geschreven wordt.
(dan kan "ws.columns(4).delete" uiteraard ook vervallen)

Ik weet zeker dat het mogelijk moet zijn met Arrays maar kom er niet uit. Wie wil/kan me verder helpen?
Het voorbeeldbestand hecht ik aan.

Alvast dank voor jullie hulp!

Groet,
Hela1966
 

Bijlagen

  • Test Compare_Highlight.xlsm
    24,4 KB · Weergaven: 18
Hola, Hela

Ça va ?

Zo ?
Verwijder Option Explicit
Zet de code in de macromodule van Sheet1
Overbodige spaties, zoals achter Bruxelles worden genegeerd.

Code: 
Sub M_snb()
   c00 = "àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ'‘’"
   c01 = "aaaaaaceeeeiiiidnooooouuuuyySZszYAAAAAACEEEEIIIIDNOOOOOUUUUY   "
       
   sn = Cells(1).CurrentRegion
   For j = 2 To UBound(sn)
     For jj = 1 To Len(sn(j, 2))
       y = InStr(c00, Mid(sn(j, 2), jj, 1))
       If y Then sn(j, 2) = Replace(sn(j, 2), Mid(sn(j, 2), jj, 1), Mid(c01, y, 1))
     Next
     If LCase(Trim(sn(j, 2))) <> LCase(Trim(sn(j, 3))) Then Cells(j, 3).Interior.ColorIndex = 7
  Next
End Sub
 
Laatst bewerkt:
Hoi SNB!

Ja hier alles helemaal in orde, bij jou ook hopelijk!
Volop thuiswerken dus volop tijd voor Excel (hihi)

Dank voor je superkorte code, het werkt weer gesmeerd EN ik kan het nog redelijk "lezen" ook.
Wat die spatie betreft, die zou ik toch graag ook highlighten als een fout (had die express in het voorbeeld verwerkt)
daar de data soms die overtollige spaties bevat en verderop in het proces soms problemen geven.

Hoe kan ik dat het best aanpassen (heeft te maken met die Trim toch?)

Alvast dank!

Gr,
Hela
 
Sorry SNB, vergeet die laatste vraag maar....oplossing gevonden.
Dadelijk nog wel een aanvullende vraag hierover. Even puzzelen of ik het zelf kan bedenken.
 
En....done!
Wat lekker weer, het is me gelukt om de code zodanig aan te passen dat het gebruikt kan worden op een vrij groot bestand.
Dat scheelt zoveel rekenwerk en geeft gelijk een goed visueel beeld. Helemaal blij mee.

Deze zal ik markeren als opgelost en wil ik wederom mijn enorme dank uitspreken!
Tot een volgende SNB enne....be zeef!

Gr,
Hela
 
Kiek nou; twee vragen zelf opgelost. Prima.
Hopelijk is het Array-gebruik nu ook gesneden koek voor je.

PS. Ik zal me voorlopig sociaal even koest houden (tot na de 'booster'-prik)
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan