• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

kolom vergelijken en kopieren

Status
Niet open voor verdere reacties.

vrouw

Terugkerende gebruiker
Lid geworden
27 mrt 2010
Berichten
1.525
dmv al vele hulp op dit forum ben ik tot onderstaande code gekomen om o.a
De data van kolom I op tabblad "update" te vergelijken met kolom I op tabblad basis. Als dat afwijkt word de data van tab Update (kolom i) in tab basis (kolom i) gekopieerd.

mijn vraag:
Nu zou ik graag willen dat dat ook met de kolommen L t/m Q gebeurd.
Ik weet echter niet hoe en waar ik onderstaande macro moet aanpassen.

Code:
Private Sub Worksheet_Activate()
'Als tabblad update leeg is word schakelen naar tabblad Basis geblokkeerd.

Application.ScreenUpdating = False
    If WorksheetFunction.CountBlank(Sheets(2).Range("A4:Q10")) = 119 Then
      Sheets(2).Activate
       MsgBox (" Als dit werkblad leeg is kan en moet je niet schakelen naar ander tabblad want dat heeft geen zin!")
        Exit Sub
    End If
  Application.ScreenUpdating = True

'----------------------------

Dim iRij As Integer
Dim Rij As Integer
Dim iTest As Integer
Dim sUniek As String
Dim iEinde As Integer
Dim iEinde2 As Integer
Dim c1 As Range
Dim c2 As Range
Dim r1 As Range
Dim r2 As Range

   On Error GoTo Worksheet_Change_Error

iEinde = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row 'stel het einde van de babis range in.
iEinde2 = 3 + Application.WorksheetFunction.CountA(Sheet3.Range("A4:A4000")) 'stel het einde van de geïmporteerde lijst in.
If iEinde = 0 Or iEinde2 = 0 Then Exit Sub ' Verlaat de sub als het bereik leeg is.

Application.EnableEvents = False
Application.ScreenUpdating = False

Set r1 = Sheet1.Range("T4:T" & iEinde)
Set r2 = Sheet3.Range("B4:b" & iEinde2)
If Range("a4") = "" Then Exit Sub
        'Sheet1.Range("I4:I" & iEinde).Font.ColorIndex = 1 'reset de tekstkleur
For iRij = 4 To iEinde 'zoek net meer bestaande rijen
    For Rij = 4 To iEinde2
        If Sheet1.Range("T" & iRij) = Sheet3.Range("B" & Rij) & Sheet3.Range("H" & Rij) Then Exit For
    Next Rij
 If Rij = iEinde2 + 1 Then Sheet1.Range("A" & iRij, "S" & iRij).ClearContents 'weg ermee
sUniek = Sheet3.Cells(iRij, 2) & Sheet3.Cells(iRij, 8) 'combineer de unieke nummers
    If Application.WorksheetFunction.CountIf(r1, sUniek) > 0 Then 'is het uniek nummer aanwezig in het basissheet
            iTest = Application.WorksheetFunction.Match(sUniek, r1, 0) + 3 'zoek het rijnummer op
        Set c1 = Sheet1.Cells(iTest, 9)
        Set c2 = Sheet3.Cells(iRij, 9)
            If c2 <> c1 Then 'is de waarde ongelijk, dan;
            Sheet1.Cells(iTest, 11) = c1 'zet de oude waarde in K
            c1 = c2 'pas deze aan
            Sheet1.Cells(iTest, 11).Font.ColorIndex = 3
            c1.Font.ColorIndex = 3
         End If
    End If
Next iRij
Sheet1.Range("A4:Z" & iEinde).Sort Sheet1.Range("a4")
'stel alles weer terug
Set c1 = Nothing
Set c2 = Nothing
Set r1 = Nothing
Set r2 = Nothing
Application.EnableEvents = True

Updaten

   On Error GoTo 0
   Exit Sub
'Foutafhandeling ===================================================================================================
Worksheet_Change_Error:
Application.EnableEvents = True
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Worksheet_Change of VBA Document Sheet3"
End Sub

Voor de zekerheid ook maar even een (uitgekleed) bestand bijgedaan.

Voor de volledigheid:
Ik ben lang met dit topic bezig geweest maar daar kwam geen antwoord meer vandaar dat ik de vraag nu ander en opnieuw formuleer.
 

Bijlagen

Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan