Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, rngToDo As Range, firstAddress As String, SHTEST1 As Object
If Target.Count > 1 Then Exit Sub
'Naamtoewijzing voor een werkblad of bestandslocatie. Hierna kan de naam worden aangeroepen'
Set SHTEST1 = Workbooks.Open("C:\TEST2.xls").Sheets("TEST2")
'Invoercel met waarde welke later wordt vergeleken'
If Target.Address = "$B$5" Then
Application.ScreenUpdating = False
'Op het actieve werkblad wordt vanaf Cel X alles gewist'
Range("A32").CurrentRegion.Offset(1).ClearContents
'Op het gegevensblad kijk vanaf Cel X naar rechts en naar beneden (kijk naar het geheel)'
Set rngToDo = SHTEST1.Range("A2", SHTEST1.Range("A2").End(xlDown))
Set c = rngToDo.Find(Target, after:=SHTEST1.Cells(Rows.Count, rngToDo.Column).End(xlUp), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Copy
Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'Hier wordt aangegeven welke kolommen op het gegevensblad gekopieerd moeten worden naar het doel werkblad'
'_____________________________________________________________________________________________________________'
'Verander in de 1e regel tussen de "" de kolomletter waar de gegevens vandaan komen'
'Verander in de 2e regel de eerste "" in de kolomletter waar de gegevens naar toe moeten'
[B]SHTEST1.Range("F" & c.Row).Copy
Range("B" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial [/B]xlPasteValues
'Uitbereiding door kopieren'
SHTEST1.Range("H" & c.Row).Copy
Range("C" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
'_____________________________________________________________________________________________________________'
'Hierboven kan uitbereiding plaats vinden van de kolommen die gekopieerd moeten worden'
Set c = rngToDo.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Application.EnableEvents = False
