Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo LoiCT
If Not Intersect(Columns("B:B"), Target) Is Nothing And IsNumeric(Target.Offset(, -1)) Then
Dim RngVLK As Range, sRng As Range, RngVL As Range, Clls As Range
Dim Rng As Range, RngNC As Range, RngM As Range, RngMK As Range
Range(Target.Offset(2, 1), Target.Offset(2, 1).End(xlDown)).Resize(, 3).Clear
With Sheets("DM")
Set Rng = .Range(.[A5], .Cells(.[D65432].End(xlUp).Row, 1))
Set sRng = Rng.Find(Target, LookIn:=xlValues, LOOKAT:=xlWhole).Offset(1, 2)
If Not sRng Is Nothing Then _
Set sRng = .Range(sRng, sRng.End(xlDown))
For Each Clls In sRng
If Clls.Value = "VL" Then
If RngVL Is Nothing Then
Set RngVL = Clls.Offset(, 1).Resize(, 3)
Else
Set RngVL = Union(RngVL, Clls.Offset(, 1).Resize(, 3))
End If
End If
If Clls.Value = "VLK" Then Set RngVLK = Clls.Offset(, 1).Resize(, 3)
If Clls.Value = "NC" Then Set RngNC = Clls.Offset(, 1).Resize(, 3)
If Clls.Value = "M" Then
If RngM Is Nothing Then
Set RngM = Clls.Offset(, 1).Resize(, 3)
Else
Set RngM = Union(RngM, Clls.Offset(, 1).Resize(, 3))
End If
End If
If Clls.Value = "MK" Then Set RngMK = Clls.Offset(, 1).Resize(, 3)
Next Clls
Target.Offset(2, 1).Resize(9, 3).Clear
If Not RngVL Is Nothing Then _
RngVL.Copy Destination:=Target.Offset(2, 1)
If Not RngVLK Is Nothing Then _
RngVLK.Copy Destination:=Target.Offset(12, 1)
If Not RngNC Is Nothing Then _
RngNC.Copy Destination:=Target.Offset(14, 1)
Target.Offset(17, 1).Resize(8, 3).Clear
If Not RngM Is Nothing Then _
RngM.Copy Destination:=Target.Offset(17, 1)
If Not RngMK Is Nothing Then _
RngMK.Copy Destination:=Target.Offset(25, 1)
End With
End If
ErrCT: Exit Sub
LoiCT:
MsgBox Error, , Err
End Sub