Seperate Repeating Info into One Line while deleting others
 

Hi -

I'm trying to seperate out repeating info (last column has unique
data) and place them into a new line.

For example:

12345 CBB
12345 GGG
54321 PPP
99999 BBB
99999 AXZ

Would turn into

12345 CBB GGG
54321 PPP
99999 BBB AXZ

I've been trying to do this through a macro by reading in every row
and matching if the first column matches the second column then take
whats in the first column and place into the last column then delete
the first row.

But I havn't found a great way in code to do this yet. My first
problem is that I can't determine how many times the number would
repeat so I don't know how many columns to go over etc...

Thanks for any help on this,

- Tek

Seperate Repeating Info into One Line while deleting others
 

Try this

Sub Test()
Dim myCell As Range
Dim aWS As Worksheet
Dim lRow As Long
Dim myDeleteRange As Range

Set aWS = ActiveSheet
lRow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).row
Set myCell = aWS.Range("A1") '<~~~change first cell as needed

Do
If myCell.Offset(1, 0).Value = myCell.Value Then
lcol = aWS.Cells(myCell.row, aWS.Columns.Count).End(xlToLeft).Column
+ 1
myCell.Offset(0, lcol - myCell.Column).Value = myCell.Offset(1,
1).Value
If myDeleteRange Is Nothing Then
Set myDeleteRange = myCell.Offset(1, 0)
Else
Set myDeleteRange = Union(myDeleteRange, myCell.Offset(1, 0))
End If

End If
Set myCell = myCell.Offset(1, 0)

Loop While myCell.row < lRow

If Not myDeleteRange Is Nothing Then
Debug.Print myDeleteRange.Address
myDeleteRange.EntireRow.Delete
End If

End Sub

--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.



" wrote:

Hi -

I'm trying to seperate out repeating info (last column has unique
data) and place them into a new line.

For example:

12345 CBB
12345 GGG
54321 PPP
99999 BBB
99999 AXZ

Would turn into

12345 CBB GGG
54321 PPP
99999 BBB AXZ

I've been trying to do this through a macro by reading in every row
and matching if the first column matches the second column then take
whats in the first column and place into the last column then delete
the first row.

But I havn't found a great way in code to do this yet. My first
problem is that I can't determine how many times the number would
repeat so I don't know how many columns to go over etc...

Thanks for any help on this,

- Tek

Seperate Repeating Info into One Line while deleting others
 

Barb - thanks for your marco. But it does not work if you have more than 2
repeating values in the first column.

12345 CBB
12345 XXX
12345 HHH
54321 PPP
99999 BBB
99999 AXZ


"Barb Reinhardt" wrote:

Try this

Sub Test()
Dim myCell As Range
Dim aWS As Worksheet
Dim lRow As Long
Dim myDeleteRange As Range

Set aWS = ActiveSheet
lRow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).row
Set myCell = aWS.Range("A1") '<~~~change first cell as needed

Do
If myCell.Offset(1, 0).Value = myCell.Value Then
lcol = aWS.Cells(myCell.row, aWS.Columns.Count).End(xlToLeft).Column
+ 1
myCell.Offset(0, lcol - myCell.Column).Value = myCell.Offset(1,
1).Value
If myDeleteRange Is Nothing Then
Set myDeleteRange = myCell.Offset(1, 0)
Else
Set myDeleteRange = Union(myDeleteRange, myCell.Offset(1, 0))
End If

End If
Set myCell = myCell.Offset(1, 0)

Loop While myCell.row < lRow

If Not myDeleteRange Is Nothing Then
Debug.Print myDeleteRange.Address
myDeleteRange.EntireRow.Delete
End If

End Sub

--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.



" wrote:

Hi -

I'm trying to seperate out repeating info (last column has unique
data) and place them into a new line.

For example:

12345 CBB
12345 GGG
54321 PPP
99999 BBB
99999 AXZ

Would turn into

12345 CBB GGG
54321 PPP
99999 BBB AXZ

I've been trying to do this through a macro by reading in every row
and matching if the first column matches the second column then take
whats in the first column and place into the last column then delete
the first row.

But I havn't found a great way in code to do this yet. My first
problem is that I can't determine how many times the number would
repeat so I don't know how many columns to go over etc...

Thanks for any help on this,

- Tek

Seperate Repeating Info into One Line while deleting others
 

Hi Barb -

Thanks for the response! This is pretty close, but it indeed only
worked if you only have 2 repeating rows otherwise it strips off the
third row. Although I'm going to see if I can't figure out a way to
fix it using the code you posted.

Thanks,

- Tek

Seperate Repeating Info into One Line while deleting others
 

On Thu, 2 Oct 2008 15:11:45 -0700 (PDT), wrote:

Hi -

I'm trying to seperate out repeating info (last column has unique
data) and place them into a new line.

For example:

12345 CBB
12345 GGG
54321 PPP
99999 BBB
99999 AXZ

Would turn into

12345 CBB GGG
54321 PPP
99999 BBB AXZ

I've been trying to do this through a macro by reading in every row
and matching if the first column matches the second column then take
whats in the first column and place into the last column then delete
the first row.

But I havn't found a great way in code to do this yet. My first
problem is that I can't determine how many times the number would
repeat so I don't know how many columns to go over etc...

Thanks for any help on this,

- Tek

This should work. As written, it returns the data sorted in the order of
frequency of the numbers.

As written, the Combine macro will act on "Selection" (actually, you only have
to select the first column of data) and place the results starting in A20.

Both of those parameters could be easily changed to meet your requirements.


===============================================
Option Explicit
Sub Combine()
Dim c As Range
Dim rg As Range
Dim rDest As Range
Dim sSerialNums As Variant
Dim aRes()
Dim i As Long, j As Long

'can determine rg to check in many ways
'this is just one:
Set rg = Selection.Resize(Selection.Rows.Count, 1)

'Again, many ways to determine where to put the results
Set rDest = Range("A20")

sSerialNums = UniqueCount(rg)
ReDim aRes(0 To UBound(sSerialNums, 2) - 1, 0 To sSerialNums(1, 1))

For i = 0 To UBound(sSerialNums, 2) - 1
aRes(i, 0) = sSerialNums(0, i + 1)
j = 1
Do Until j sSerialNums(1, i + 1)
For Each c In rg
If c.Value = aRes(i, 0) Then
aRes(i, j) = c.Offset(0, 1)
j = j + 1
End If
Next c
Loop
Next i

For i = 0 To UBound(aRes)
For j = 0 To UBound(aRes, 2)
rDest(i + 1, j + 1) = aRes(i, j)
Next j
Next i
End Sub
'--------------------------------------------
Function UniqueCount(rg As Range)
'Returns a horizontal two dimensional
' array of unique words and count
Dim cWordList As Collection
Dim Str As String
Dim sRes() As Variant
Dim i As Long, j As Long
Dim c As Range

'get list of unique words
Set cWordList = New Collection

On Error Resume Next
For Each c In rg
cWordList.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0

ReDim sRes(0 To 1, 1 To cWordList.Count)
For i = 1 To cWordList.Count
sRes(0, i) = cWordList(i)
Next i

'get word count for each word
For i = 1 To UBound(sRes, 2)
sRes(1, i) = Application.WorksheetFunction.CountIf(rg, sRes(0, i))
Next i

'Reverse sorting order if you want the words alphabetically
'without respect to the counts

'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True

'then sort by Count highest to lowest
BubbleSortX sRes, 1, False

UniqueCount = sRes
End Function
'--------------------------------------------------------------
Private Sub BubbleSortX(TempArray As Variant, d As Long, _
bSortDirection As Boolean)
'bSortDirection = True means sort ascending
'bSortDirection = False means sort descending
Dim Temp1 As Variant, Temp2
Dim i As Long
Dim NoExchanges As Boolean
Dim Exchange As Boolean

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 1 To UBound(TempArray, 2) - 1

' If the element is greater/less than the element
' following it, exchange the two elements.

Exchange = TempArray(d, i) < TempArray(d, i + 1)
If bSortDirection = True Then Exchange = _
TempArray(d, i) TempArray(d, i + 1)
If Exchange Then
NoExchanges = False
Temp1 = TempArray(0, i)
Temp2 = TempArray(1, i)
TempArray(0, i) = TempArray(0, i + 1)
TempArray(1, i) = TempArray(1, i + 1)
TempArray(0, i + 1) = Temp1
TempArray(1, i + 1) = Temp2
End If
Next i
Loop While Not (NoExchanges)
End Sub
======================================
--ron