Listing the date, activity and name on a rota

[hurcuma]

Hi

We prepare a rota where volunteers assist with activities at Church, we normally just give out the rota (an excel sheet), but a number of people volunteer for more than one thing.

What I would like to do is to to give them a printed list showing in chronological order the activity they are assigned to. (thinking if I can achieve a listing, I can do a mail merge from excel into word so that I can include some additional text.

The mail merge part I am fine with.

I am struggling with how to take the table below, and transform it to the example I have called output below, it will obviously need to repeat moving on the next volunteer in the table.


Assuming Headings is Row 1 with columns A through to G

Date	Deacon	Vestibule	Church am	Front door	Projection Sunday	Car Park
07-Jan	M Bond	V Bond	R Pedro	G Pedro	R Townsend	S Everton
14-Jan	R Cole	B Bond	C Chaplin	J L-Rogers/J Patel	R Townsend	T Thompson
21-Jan	N Smith	B&B Smith	M Roberts	L Musk	M Murray	S Musk
28-Jan	A Hill	A Rogers	M Bond	N Thompson	M Murray	N Smith
04-Feb	S Everton	B L-Rogers	J Harper	S Musk	K Townsend	W Brown
11-Feb	M Bond	C Smith	H Thompson	T Thompson	R Townsend	L Musk
18-Feb	R Cole	M Gallagher	V Rogers	T Lamont	R Townsend	M Bond
25-Feb	N Smith	A Bashar	R Matthews	T Matthews	M Murray	T Lamont
Output
Date	Name	Activity
07-Jan	M Bond	Deacon
28-Jan	M Bond	Church AM
11-Feb	M Bond	Deacon
18-Feb	M Bond	Car Park

<colgroup><col><col><col span="2"><col><col><col></colgroup><tbody>
</tbody>

Would any one be able to help me out on this as I am stumped on where to start. Many thanks

<colgroup><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[iggydarsa]

How about this:

simple modification to my original code:

Sub Transfer (byval s as String)
    'Clear Output sheet
    Sheets("Output").Range("A2:C" & Rows.Count).ClearContents
    rowOutput = 2
    
    'Find lastrow
    lrInput = Sheets("Input").Range("A" & Rows.Count).End(xlUp).Row
    
    'Search for name passed through
    nm = s
    
    For r = 2 To lrInput 'loop through the rows
        For c = 2 To 7 'loop through columns B through G
            If Sheets("Input").Cells(r, c).Value = nm Then 'if name matches then transfer to Output
                Sheets("Output").Range("A" & rowOutput).Value = Sheets("Input").Range("A" & r).Value 'Date
                Sheets("Output").Range("B" & rowOutput).Value = nm 'Name
                Sheets("Output").Range("C" & rowOutput).Value = Sheets("Input").Cells(1, c).Value 'Activity
                rowOutput = rowOutput + 1
            End If
        Next c
    Next r
    'Here you will need to find a macro that does the printing action
End Sub

Then you create another macro below it that calls the one above:

Sub Caller()
    lr = Range("A" & Rows.Count).End(xlUp).Row
    for I=60 to lr
        Call Transfer(Range("A" & I).value)
    Next I 
End Sub

Then your shape button will call the Caller macro