Concatenating unique cells (vertically), leaving "; " between results (for emails)

Hi all
I'm creating a macro to compile some emails but taking the necessary addresses information from the spreadsheet.

I have some email addresses in lets say column H (row 8 downwards). Lets say as per example below.

----------------- ------------col H
Row 8--------------- empty cell-----------
Row 9--------------- empty cell-----------
Row 10------- John.smith1@hotmail.com
Row 11------- John.smith1@hotmail.com
Row 12------- John.smith1@hotmail.com
Row 13--------------- empty cell-----------
Row 14------- John.smith14@hotmail.com
Row 15------- John.smith18@hotmail.com
Row 16------- John.smith24@hotmail.com
Row 17--------------- empty cell-----------
Row 18------- John.smith30@hotmail.com

Now, I'm after a macro or formula that would look the information from H8 (inclusive) downwards as far as per last cell used in column A. Now it should take all the unique email addresses and concatenate them together and use "; " (read semicolon + 1 space) and populate this into cell H3.

In our example the correct result in H3 would be like this:
John.smith1@hotmail.com; John.smith14@hotmail.com; John.smith18@hotmail.com; John.smith24@hotmail.com; John.smith30@hotmail.com;

But not like this:
John.smith1@hotmail.com; John.smith1@hotmail.com; John.smith1@hotmail.com; John.smith14@hotmail.com; John.smith18@hotmail.com; John.smith24@hotmail.com; John.smith30@hotmail.com;


I have attached and example spreadsheet. It has sheet "Before", "After" and ""But not like this"

My intention is use some email compiling macros, that would take the email addresses from H3.

Does anyone know how to achieve this sort of concatenation?
Any help is greatly appreciated.
Cheers

Hello rain4u,

The macro below setups up both the recipients and CC email columns "H3" and "I3" with the unique addresses separated by a semi-colon and a space. It has been added to the attached workbook.

' Thread:  http://www.excelforum.com/excel-programming/793315-concatenating-unique-cells-vertically-leaving-between-results-for-emails.html
' Poster:  rain4u
' Written: September 21, 2011
' Author:  Leith Ross

Sub CreateEmailLists()

  Dim Dict As Object
  Dim ListCell As Range
  Dim R As Long
  Dim Recipients As String
  Dim Rng As Range
  Dim RngEnd As Range
  Dim StartRng As Range
  Dim Wks As Worksheet
  
  
      Set Wks = Worksheets("Before")
      
      Set ListCell = Wks.Range("H3")
      Set StartRng = Wks.Range("H8")
      
          GoSub CreateList
          
      Set ListCell = Wks.Range("I3")
      Set StartRng = Wks.Range("I8")
      
          GoSub CreateList
      
Exit Sub


CreateList:

      Set RngEnd = Wks.Cells(Rows.Count, StartRng.Column).End(xlUp)
      If RngEnd.Row < StartRng.Row Then Exit Sub Else Set Rng = Wks.Range(StartRng, RngEnd)
      
        Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
        
        For R = 1 To Rng.Rows.Count
            If StartRng.Item(R, 1) <> "" Then
               If Not Dict.Exists(Rng.Item(R, 1).Value) Then
                  Dict.Add Rng.Item(R, 1).Value, R
                  Recipients = Recipients & Rng.Item(R, 1) & "; "
               End If
            End If
        Next R
        
      ListCell = Left(Recipients, Len(Recipients) - 2)
      
Return

End Sub

Hello Rain4u,

Glad you like it. That will be 25 cents to the egress.

Hello rain4u,

Looks like I owe a refund. WTF is going on? I will look this over to find the cause. This should not be happening.

Hello Rain4u,

What a beginner's mistake! I did not clear the Recipients string before the next call.

Here is the corrected code...

' Thread:  http://www.excelforum.com/excel-programming/793315-concatenating-unique-cells-vertically-leaving-between-results-for-emails.html
' Poster:  rain4u
' Written: September 21, 2011
' Author:  Leith Ross

Sub CreateEmailLists()

  Dim Dict As Object
  Dim ListCell As Range
  Dim R As Long
  Dim Recipients As String
  Dim Rng As Range
  Dim RngEnd As Range
  Dim StartRng As Range
  Dim Wks As Worksheet
  
  
      Set Wks = Worksheets("Before")
      
      Set ListCell = Wks.Range("H3")
      Set StartRng = Wks.Range("H8")
      
          GoSub CreateList
          
      Set ListCell = Wks.Range("I3")
      Set StartRng = Wks.Range("I8")
      
          GoSub CreateList
      
Exit Sub


CreateList:
      
      Set RngEnd = Wks.Cells(Rows.Count, StartRng.Column).End(xlUp)
      If RngEnd.Row < StartRng.Row Then Exit Sub Else Set Rng = Wks.Range(StartRng, RngEnd)
      
        Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
      
        Addx = Rng.Address
        N = Dict.Count
        
        For R = 1 To Rng.Rows.Count
            If Rng.Item(R, 1) <> "" Then
               If Not Dict.Exists(Rng.Item(R, 1).Value) Then
                  Dict.Add Rng.Item(R, 1).Value, R
                  Recipients = Recipients & Rng.Item(R, 1) & "; "
               End If
            End If
        Next R
        
      ListCell = Left(Recipients, Len(Recipients) - 2)
      Recipients = ""
      
Return

End Sub