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