Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr As Range, sArr, dArr, I&, K&, Cll As Range, Col&, Dk As String
Dk = [B4].Value
Application.ScreenUpdating = False
If Target.Address = "$B$4" Then
With Sheet2
Set Arr = .Range(.[B6], .[B6].End(2))
For Each Cll In Arr
If Cll.Value = Dk Then
Col = Cll.Column - 1: Exit For
End If
Next Cll
If Col Then
sArr = .Range(.[A7], .[A65000].End(3)).Offset(, Col).Resize(, 2).Value
Else
Range("A7:C65000").ClearContents: Exit Sub
End If
End With
ReDim dArr(1 To UBound(sArr), 1 To 4)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> Empty Then
K = K + 1
dArr(K, 1) = K
dArr(K, 2) = sArr(I, 1)
dArr(K, 3) = sArr(I, 2)
dArr(K, 4) = "=RAND()"
End If
Next I
Range("A7:C65000").ClearContents
If K Then
Range("A7").Resize(K, 4).Value = dArr
Range("B7").Resize(K, 3).Sort [D7], xlAscending
Range("D7").Resize(K).ClearContents
End If
End If
Application.ScreenUpdating = True
End Sub
