I have a table as shown below, I want to create another one that put all
Territory together into one cell that corresponding to unique County.

County Territory
Bell 0033
Bell 0036
Bell 0034
Boone 0052
Boone 0053
Boone 0055
Boone 0046
Boone 0054


County Territory
Bell 0031, 0034, 0036
Boone 0052, 0053, 0055, 0046, 0054

My VB skill is very limited:(
My code is:

Sub Union()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Dim iRows As Long, mRow As Long, ir As Integer, ic As Integer, rng As Range
iRows = Selection.Rows.Count
Set Lastcell = Cells.SpecialCells(xlLastCell)
mRow = Lastcell.Row
If mRow < iRows Then iRows = mRow
Set rng = ActiveSheet.Range(G1, H26)

For ic = 1 To 26

County = rng.Item(ic, 1).Value
Terr = rng.Item(ic, 2).Value
For ir = 1 To iRows
Combined = Selection.Item(ir, 2).Value
Compared = Trim(Selection.Item(ir, 1).Value)
If County = Compared Then Terr = Terr & ", " & Combined
Next ir
Next ic
Application.ScreenUpdating = True

End Sub

Please help.
Thanks,

Lots of times when you're inserting or deleting rows, it's much easier to start
at the bottom and work your way to the top.

Option Explicit
Sub testme()
Dim iRow As Long
Dim LastRow As Long
Dim FirstRow As Long

With Worksheets("sheet1")
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If LCase(Trim(.Cells(iRow, "A").Value)) _
= LCase(Trim(.Cells(iRow - 1, "A").Value)) Then
'same, so do some work
.Cells(iRow - 1, "B").Value _
= .Cells(iRow - 1, "b").Value _
& ", " & .Cells(iRow, "b").Value
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub

Save your work first--since it deletes the old rows.


Lily wrote:

I have a table as shown below, I want to create another one that put all
Territory together into one cell that corresponding to unique County.

County Territory
Bell 0033
Bell 0036
Bell 0034
Boone 0052
Boone 0053
Boone 0055
Boone 0046
Boone 0054

County Territory
Bell 0031, 0034, 0036
Boone 0052, 0053, 0055, 0046, 0054

My VB skill is very limited:(
My code is:

Sub Union()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Dim iRows As Long, mRow As Long, ir As Integer, ic As Integer, rng As Range
iRows = Selection.Rows.Count
Set Lastcell = Cells.SpecialCells(xlLastCell)
mRow = Lastcell.Row
If mRow < iRows Then iRows = mRow
Set rng = ActiveSheet.Range(G1, H26)

For ic = 1 To 26

County = rng.Item(ic, 1).Value
Terr = rng.Item(ic, 2).Value
For ir = 1 To iRows
Combined = Selection.Item(ir, 2).Value
Compared = Trim(Selection.Item(ir, 1).Value)
If County = Compared Then Terr = Terr & ", " & Combined
Next ir
Next ic
Application.ScreenUpdating = True

End Sub

Please help.
Thanks,

--

Dave Peterson

This is SO Cool! It works perfectly. Thanks a million!
Lily

"Dave Peterson" wrote:

Lots of times when you're inserting or deleting rows, it's much easier to start
at the bottom and work your way to the top.

Option Explicit
Sub testme()
Dim iRow As Long
Dim LastRow As Long
Dim FirstRow As Long

With Worksheets("sheet1")
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If LCase(Trim(.Cells(iRow, "A").Value)) _
= LCase(Trim(.Cells(iRow - 1, "A").Value)) Then
'same, so do some work
.Cells(iRow - 1, "B").Value _
= .Cells(iRow - 1, "b").Value _
& ", " & .Cells(iRow, "b").Value
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub

Save your work first--since it deletes the old rows.


Lily wrote:

I have a table as shown below, I want to create another one that put all
Territory together into one cell that corresponding to unique County.

County Territory
Bell 0033
Bell 0036
Bell 0034
Boone 0052
Boone 0053
Boone 0055
Boone 0046
Boone 0054

County Territory
Bell 0031, 0034, 0036
Boone 0052, 0053, 0055, 0046, 0054

My VB skill is very limited:(
My code is:

Sub Union()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Dim iRows As Long, mRow As Long, ir As Integer, ic As Integer, rng As Range
iRows = Selection.Rows.Count
Set Lastcell = Cells.SpecialCells(xlLastCell)
mRow = Lastcell.Row
If mRow < iRows Then iRows = mRow
Set rng = ActiveSheet.Range(G1, H26)

For ic = 1 To 26

County = rng.Item(ic, 1).Value
Terr = rng.Item(ic, 2).Value
For ir = 1 To iRows
Combined = Selection.Item(ir, 2).Value
Compared = Trim(Selection.Item(ir, 1).Value)
If County = Compared Then Terr = Terr & ", " & Combined
Next ir
Next ic
Application.ScreenUpdating = True

End Sub

Please help.
Thanks,

--

Dave Peterson