Need some help with extracting unique values(tricky..).

<font face=Courier New>
' ZVI:2009-03-02 http://www.mrexcel.com/forum/showthread.php?t=374600
Sub Start()
  Dim Arr, Tmp, Dic, s As String, i As Long, x, cs
  Const Title = "name1"         ' <-- Title to be skipped
  Const SheetFrom = 1           ' <-- Sheet with input data, string or numeric
  Const SheetTo = 2             ' <-- Sheet with output data, string or numeric
  Const ColumnsFrom = "B:C,H:I" ' <-- List of input colums (pared)
  '  Clear destination
  With Sheets(SheetTo)
    Application.Intersect(.UsedRange, .Columns("A:B")).ClearContents
  End With
  ' Build unique from B:C & H:I
  With CreateObject("Scripting.Dictionary") 'Dic
    .CompareMode = vbTextCompare
    For Each cs In Split(ColumnsFrom, ",")
      Arr = Application.Intersect(Sheets(SheetFrom).UsedRange, Sheets(SheetFrom).Columns(Trim(cs))).Value
      For i = 1 To UBound(Arr)
        If Len(Arr(i, 1)) > 1 And Arr(i, 1) <> Title Then
          For Each x In Split(Arr(i, 2), vbLf)
            If Len(x) > 0 Then
              s = Arr(i, 1) & vbLf & x
              If Not .Exists(s) Then .Add s, 0
            End If
          Next
        End If
      Next
    Next
    ' Copy result to Arr
    On Error GoTo exit_:
    Tmp = .Keys
    ReDim Arr(1 To .Count, 1 To 2)
    For i = 1 To .Count
      x = Split(Tmp(i - 1), vbLf)
      Arr(i, 1) = x(0)
      Arr(i, 2) = x(1)
    Next
  End With
  ' Copy result to Sheets(2)
  With Application
    ' Freeze on
    .EnableEvents = False
    .ScreenUpdating = False
    ' Write result to destination columns
    With Sheets(SheetTo).Range("A1").Resize(UBound(Arr), 2)
      ' Copy result as values
      .Value = Arr
      ' Sort resulting columns
      .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
            Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlNo
      ' Del equal items in Columns(1)
      Arr = .Columns(1)
      s = Arr(1, 1)
      For i = 2 To UBound(Arr)
        If Arr(i, 1) = s Then Arr(i, 1) = "" Else s = Arr(i, 1)
      Next
      .Columns(1).Value = Arr
    End With
    ' Freeze off
    .EnableEvents = True
    .ScreenUpdating = True
  End With
  Exit Sub
exit_:
  MsgBox Err.Number & vbLf & Err.Description, vbCritical, "Error!"
End Sub
</FONT>

<font face=Courier New>
Sub Start()
  Dim Arr, Tmp, s As String, i As Long, x, cs
  Const Title = "name1"         ' <-- Title to be skipped
  Const SheetFrom = 1           ' <-- Sheet with input data, string of numeric
  Const SheetTo = 2             ' <-- Sheet with output data, string of numeric
  Const ColumnsFrom = "B:C,H:I" ' <-- List of input colums (pared)
  '  Clear destination
  With Sheets(SheetTo)
    Application.Intersect(.UsedRange, .Columns("A:C")).ClearContents
  End With
  ' Build unique from B:C & H:I
  With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each cs In Split(ColumnsFrom, ",")
      Arr = Application.Intersect(Sheets(SheetFrom).UsedRange, Sheets(SheetFrom).Columns(Trim(cs))).Value
      For i = 1 To UBound(Arr)
        If Len(Arr(i, 1)) > 0 And Arr(i, 1) <> Title Then
          For Each x In Split(Arr(i, 2), vbLf)
            If Len(x) > 0 Then
              s = Arr(i, 1) & vbLf & x
              If Not .Exists(s) Then .Add s, 1 Else .Item(s) = .Item(s) + 1
            End If
          Next
        End If
      Next
    Next
    ' Copy result to Arr
    On Error GoTo exit_:
    Tmp = .Keys
    ReDim Arr(1 To .Count, 1 To 3)
    For i = 1 To .Count
      x = Split(Tmp(i - 1), vbLf)
      Arr(i, 1) = x(0)
      Arr(i, 2) = x(1)
      Arr(i, 3) = .Item(Tmp(i - 1))
    Next
  End With
  ' Copy result to Sheets(2)
  With Application
    ' Freeze on
    .EnableEvents = False
    .ScreenUpdating = False
    ' Write result to destination columns
    With Sheets(SheetTo).Range("A1").Resize(UBound(Arr), 3)
      ' Copy result as values
      .Value = Arr
      ' Sort resulting columns
      .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
            Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlNo
      ' Del equal items in Columns(1)
      Arr = .Columns(1)
      s = Arr(1, 1)
      For i = 2 To UBound(Arr)
        If Arr(i, 1) = s Then Arr(i, 1) = "" Else s = Arr(i, 1)
      Next
      .Columns(1).Value = Arr
    End With
    ' Freeze off
    .EnableEvents = True
    .ScreenUpdating = True
  End With
  Exit Sub
exit_:
  MsgBox Err.Number & vbLf & Err.Description, vbCritical, "Error!"
End Sub
</FONT>