copying duplicate entries
One way:
Option Explicit
Sub testme()
Application.screenupdating = false
Dim FirstRow As Long
Dim LastRow As Long
Dim oCol As Long
Dim oRow As Long
Dim iRow As Long
Dim curWks As Worksheet
Dim newWks As Worksheet
Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add
oRow = 1
With curWks
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
newWks.Range("a1").Value = .Cells(FirstRow, "A").Value
newWks.Range("b1").Value = .Cells(FirstRow, "B").Value
oCol = 3
For iRow = FirstRow + 1 To LastRow
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
newWks.Cells(oRow, oCol).Value = .Cells(iRow, "B").Value
oCol = oCol + 1
If oCol .Columns.Count Then
MsgBox "Too many entries at row: " & iRow
Exit Sub
End If
Else
oRow = oRow + 1
newWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
newWks.Cells(oRow, "B").Value = .Cells(iRow, "B").Value
oCol = 3
End If
Next iRow
End With
Application.screenupdating = true
End Sub
walter wrote:
I have the following list:
abc 123
abc 456
abc 789
xyz 345
xyz 987
What i want to end up with is this:
abc 123 456 789
xyz 345 987
How can this be done???
T.i.a.
Walter.
--
Dave Peterson
|