Reformat a worksheet using a macro

[Andrew Hargreaves]

I would appreciate some help on this one, if anyone can help.

I have an exported CSV file that I need to format in a more legible
manner using Excel. The file lists some dates in one row after another
and I would like all of the dates to be in one row for each property.
At the moment it looks like this:

CustomerID Service NoAccess
21 19/05/2003 20/04/2004
21 19/05/2003 07/05/2004
21 19/05/2003 20/05/2004
21 19/05/2003 02/09/2004
27 10/03/2004 17/02/2005
27 10/03/2004 08/03/2005


What I would like to see is this.

Customer ID Service No Access
21 19/05/2003 20/04/2004 07/05/2004 20/05/2004
02/03/2004
27 10/03/2004 17/02/2005 08/03/2005

etc etc

Even if someone can give me a starter I can try and go with that, but
my VBA skills are rusty.

Cheers

Andrew H

 

[Bob Phillips]

Hi Andrew,

Here is a little macro that does it

Sub Test()
Dim cLastRow As Long
Dim i As Long

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = cLastRow To 3 Step -1
If Cells(i, "A").Value = Cells(i - 1, "A").Value Then
Cells(i, "B").Resize(1, 250).Copy _
Destination:=Cells(i - 1, "D")
Cells(i, "A").EntireRow.Delete
End If
Next i

End Sub



--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Andrew Hargreaves]

Sorry for replying to my own message, but I'd just liek to say that I
eventually found a solution using one of Dave Peterson's messages from
27 Oct 2004, so thanks Dave. My solution is as follows:

Option Explicit
Sub testme()

Dim curWks As Worksheet
Dim newWks As Worksheet
Dim iCtr As Long
Dim iRow As Long
Dim oRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim DupCtr As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

iCtr = 0
newWks.Cells(1, (iCtr * 9) + 1).Resize(1, 9).Value _
= Array("CustomerID", "Old Ref", "Name", "StreetNo",
"Address", "City", "Postal Code", "Service", "No Access")


oRow = 1
With curWks
With .Range("a1:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
.Sort key1:=.Columns(1), order1:=xlAscending,
header:=xlYes
End With

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


DupCtr = 0
For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value
Then
'if continuing a row, add the details to the end of
the row.
DupCtr = DupCtr + 1
newWks.Cells(oRow, DupCtr + 9).Value _
= .Cells(iRow, 9).Value
' = .Cells(iRow, "A").Resize(9, 1).Value
Else
'When starting a new row, copy all the details to the
new row
DupCtr = 0
oRow = oRow + 1
newWks.Cells(oRow, DupCtr * 9 + 1).Resize(1, 9).Value
_
= .Cells(iRow, "A").Resize(1, 9).Value
End If

Next iRow
End With
End Sub

 

[Bob Phillips]

Mine's shorter

--

HTH

RP
(remove nothere from the email address if mailing direct)