Hi
or put this code in Sheet1 module. (Right click on Sheet1 tab name > view code > paste the code there)
Code:Dim dic As Object Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 8 Then Exit Sub Dim i As Long Dim k If dic Is Nothing Then Set dic = CreateObject("scripting.dictionary") dic.comparemode = 1 End If dic.RemoveAll If Not Intersect(Me.UsedRange, Me.Columns(8)) Is Nothing Then k = Intersect(Me.UsedRange, Me.Columns(8)).Value2 If IsArray(k) Then For i = 1 To UBound(k, 1) If Len(k(i, 1)) Then dic.Item(k(i, 1)) = Empty Next If dic.Count Then With Sheet2 .Columns(1).Clear .Cells(2, 1).Resize(dic.Count) = Application.Transpose(dic.keys) End With End If ElseIf Len(k) Then Sheet2.Columns(1).Clear: Sheet2.Cells(2, 1) = k End If End If End Sub




Reply With Quote
Bookmarks