reorder information

[ellebelle]

I have info in a spreadsheet that outlines the hours per week that a person
spends on a particular job. eg.


NAME JOB 18/6/07 25/6/07 2/7/07
Joe Bloggs ROAD 40 40 40
Charlie Brown ROAD 20 20 0
Susie Q ROAD 0 0 40
Charlie Brown BRIDGE 20 20 40
Susie Q BRIDGE 40 40 0

I would like to view this info in a different way but am not sure how to go
about it. I would like a list of names, each name appearing once and under
the date heading would appear the job that they worked on. Therefore the info
above would look like this:

NAME 18/6/07 25/6/07 2/7/07
Joe Bloggs ROAD ROAD ROAD
Charlie Brown ROAD, BRIDGE ROAD, BRIDGE BRIDGE
Susie Q BRIDGE BRIDGE ROAD

I don't want to use another sheet with formulas as it would be really heavy.
I thought running a macro would work but don't know how to do it.

Any help would be appreciated.

Ellen

 

[merjet]

The following puts your desired data below the existing data. Adapt if
you want it elsewhere.

Hth,
Merjet

Sub Macro1()
Dim c1 As Range
Dim c2 As Range
Dim iRow1 As Long
Dim iRow2 As Long
Dim iRow3 As Long

iRow1 = Range("A1").End(xlDown).Row
iRow2 = iRow1 + 2
Range("A1:A" & iRow1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A" & iRow2), Unique:=True
Range("C1:E1").Copy Range("C" & iRow2)
iRow3 = Range("A65536").End(xlUp).Row
For Each c2 In Range("A" & iRow2 + 1 & ":A" & iRow3)
For Each c1 In Range("A2:A" & iRow1)
If c1 = c2 Then
For iCol = 3 To 5
If c1.Offset(0, iCol - 1) > 0 Then c2.Offset(0, iCol -
1) _
= c2.Offset(0, iCol - 1) & c1.Offset(0, 1) & ",
"
Next iCol
End If
Next c1
Next c2
For Each c2 In Range("C" & iRow2 + 1 & ":E" & iRow3)
c2 = Left(c2, Len(c2) - 2) 'clean up -- remove last ", "
Next c2
End Sub

 

[ellebelle]

The following puts your desired data below the existing data. Adapt if
you want it elsewhere.

Hth,
Merjet

Sub Macro1()
Dim c1 As Range
Dim c2 As Range
Dim iRow1 As Long
Dim iRow2 As Long
Dim iRow3 As Long

iRow1 = Range("A1").End(xlDown).Row
iRow2 = iRow1 + 2
Range("A1:A" & iRow1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A" & iRow2), Unique:=True
Range("C1:E1").Copy Range("C" & iRow2)
iRow3 = Range("A65536").End(xlUp).Row
For Each c2 In Range("A" & iRow2 + 1 & ":A" & iRow3)
For Each c1 In Range("A2:A" & iRow1)
If c1 = c2 Then
For iCol = 3 To 5
If c1.Offset(0, iCol - 1) > 0 Then c2.Offset(0, iCol -
1) _
= c2.Offset(0, iCol - 1) & c1.Offset(0, 1) & ",
"
Next iCol
End If
Next c1
Next c2
For Each c2 In Range("C" & iRow2 + 1 & ":E" & iRow3)
c2 = Left(c2, Len(c2) - 2) 'clean up -- remove last ", "
Next c2
End Sub

Thanks, but I get an error at this line

If c1.Offset(0, iCol - 1) > 0 Then c2.Offset(0, iCol -
1) _
= c2.Offset(0, iCol - 1) & c1.Offset(0, 1) & ",
"

do you know why?

e

 

[merjet]

What kind of error? If the lines are red in the VBE it's because long
lines can get broken when posted here. The following should be only
two lines in the VBE. (In another sense, it's only one line, given the
line continuation symbol.)


If c1.Offset(0, iCol - 1) > 0 Then c2.Offset(0, iCol - 1) _
= c2.Offset(0, iCol - 1) & c1.Offset(0, 1) & ","

Hth,
Merjet

 

[merjet]

What kind of error? If the lines are red in the VBE it's because long
lines can get broken when posted here. The following should be only
two lines in the VBE. (In another sense, it's only one line, given the
line continuation symbol.)


If c1.Offset(0, iCol - 1) > 0 Then c2.Offset(0, iCol - 1) _
= c2.Offset(0, iCol - 1) & c1.Offset(0, 1) & ","

Hth,
Merjet

 

[ellebelle]

I am getting runtime error 400. Nothing is red.

 

[ellebelle]

hi, i am getting runtime error 400. there are no red lines. do you know what
could be worng? could i send you my spreadsheet?

e

 

[ellebelle]

runtime error 400. do you know how to fix it? would it be possible to send
you my spreadsheet?

e