Divide comma-separated string and look up corresponding category

[kmb1]

Hi!
I have a worksheet that lists all of the individual counties in m
state. One cell down and one cell to the right, there is a list of al
the municipalities found in that county. The number of municipalites i
the cell varies and they are separated by commas. For example:

Jameson County
Addison, Ellis, Georgetown, Poplarville
Williams County
Blenk, Crissely, Pohtawah, Stanton
Vaughnton

I would like to be able to create a new worksheet that lists all of th
municipalities in alphabetical order, and then in the adjacent cell
lists the corresponding county so that someone could look up the cit
or town name and see what county it is located in.

I would prefer to do this using a macro because I will need to repea
the steps to update the list in the future. Does anyone have an
suggestions on how I can do this? I appreciate any and all help

 

[Bernie Deitrick]

kmb,

Try the macro below on a copy of your worksheet. Assumes that your counties
are in column A, and towns in column B.

HTH,
Bernie
MS Excel MVP

Sub Macro1()
Dim myCell As Range
Dim newSheet As Worksheet
Dim mySheet As Worksheet
Dim i As Long
Dim j As Integer
Dim k As Long
Dim mySelection As Range

Columns("B:B").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
Columns("B:B").Value = Columns("B:B").Value
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("B:B").TextToColumns Destination:=Range("B1"), _
DataType:=xlDelimited, Comma:=True

Set mySheet = ActiveSheet
Set mySelection = Range("A1").CurrentRegion
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("New Database").Delete
Application.DisplayAlerts = True
Set newSheet = Worksheets.Add
newSheet.Name = "New Database"
mySheet.Activate
i = 1
For j = 1 To mySelection(mySelection.Cells.Count).Row
For k = 2 To mySelection(mySelection.Cells.Count).Column
If mySheet.Cells(j, k).Value <> "" Then
newSheet.Cells(i, 1).Value = Trim(Cells(j, 1).Value)
newSheet.Cells(i, 2).Value = Trim(Cells(j, k).Value)
i = i + 1
End If
Next k
Next j

End Sub