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.")
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