Extract unique names from within cells and paste in to a new

[inarbeth]

I have a database with parties to various legal documents listed within a large range called Parties. The range is presently in cells F3:F750 but may be expanded. Typically a cell contains information such as: ZZ Top (1) Acme Engineering 1987 Limited (2) John Lee Hooker(3).
(I made those names up.)
What I want to do is to run a macro to extract all names of more than two characters length and paste them in a column on Sheet 4 but once only. Thus if "Hooker" or "1987" appears several times they will appear once only on Sheet 4.

 

[inarbeth]

I want individual names extracted. If you can extract
H J Cotton
H Lainson
H W Pemberton
including the initials that would be brilliant. I had expected to extract
Cotton
Lainson and
Pemberton

with their initials not being counted because of my minimum of three characters criterion. That might be safer to avoid getting a name plus a bracket or a full stop.

 

[Andrew Poulsom]

Try this:

Sub Test()
    Dim Rng As Range
    Dim c As Range
    Dim Party As String
    Dim x As Integer
    Dim Char As Variant
    Dim Parties As New Collection
    Dim Item As Variant
    Set Rng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    For Each c In Rng
        Party = ""
        x = 1
        Do
            Char = Mid(c.Text, x, 1)
            If Char = "," Then
                If Len(Trim(Party)) > 0 Then
                    On Error Resume Next
                    Parties.Add Trim(Party), Trim(Party)
                    Party = ""
                    On Error GoTo 0
                End If
            ElseIf Char = "(" Then
                If Len(Trim(Party)) > 0 Then
                    On Error Resume Next
                    Parties.Add Trim(Party), Trim(Party)
                    Party = ""
                    On Error GoTo 0
                    x = x + 2
                End If
            Else
                Party = Party & Char
            End If
            x = x + 1
            If x > Len(c.Text) Then
                On Error Resume Next
                If Len(Trim(Party)) Then
                    Parties.Add Trim(Party), Trim(Party)
                End If
                On Error GoTo 0
                Exit Do
            End If
        Loop
    Next c
    Worksheets.Add
    x = 1
    For Each Item In Parties
        ActiveSheet.Cells(x, 1).Value = Item
        x = x + 1
    Next Item
End Sub

It puts them on a new sheet, but I'm sure you can live with that.

 

[inarbeth]

Andrew
You are a star. That works brilliantly. I could never have attempted this manually.
Many thanks.
Ian
This message was edited by inarbeth on 2002-11-01 12:34