Macro To Find Positive Value In One Cell Then Copy Value Of Corresponding Cells

Hi All

I have a 'rota' worksheet that includes staff names and their rostered hours on all dates through the month.

On each date of the month I need excel to find that date in column A and then look across the row to find any cells that aren't blank. When the cell has a value I need the name above it in row 1 and the value (number of hours) itself to copy across to a 'daily activities' sheet. The date is autopopulating on this sheet in cell H5.

The name needs to drop into column A and the hours worked into column B. I would like the first cell to be A9 and then down from there with no spaces in between names. The other info on the sheet will then complete itself using the name that has been dropped in using VLookup.

I'm presuming I can use a macro to do this for me but am really struggling where to start with it, and how to ignore blank cells as they will change cells on a monthly basis.

Sample.xlsm

Thanks in advance
Mark

Can you unlock the sheet please. (NVM, I just copied the sheets to a new workbook.)

Also, are you averse to switching the ROTA table so the names are down the left and dates across the top...a more standard layout and easier to read?

Will there always be only one DAILY ACTIVITIES SHEET at a time? If so, this would be simple to add an indexing column/row to the ROTAS sheet to make transfer to the DAILY sheet a breeze.

If you run this macro from the DAILY ACTIVITIES sheet, it will put the names and hours into column A:B

Option Explicit

Sub GetNamesHours()
'JBeaucaire  (11/11/2009)
Dim r As Long, ws As Worksheet, MyDate As String

MyDate = Format(Range("H5"), "DD-MMM")
Set ws = Sheets("Rotas")

With ws.Range("A:A")
r = .Find(MyDate, _
        LookIn:=xlValues, _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False, _
        SearchFormat:=False).Row
End With

Range("A9:B25").ClearContents
ws.Range(ws.Cells(r, "C"), ws.Cells(r, "AE")).SpecialCells(xlCellTypeConstants).Copy
Range("B9").PasteSpecial xlPasteValues, Transpose:=True
ws.Range(ws.Cells(r, "C"), ws.Cells(r, "AE")).SpecialCells(xlCellTypeConstants).Offset(-11, 0).Copy
Range("A9").PasteSpecial xlPasteValues, Transpose:=True
End Sub

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED].

My bad. Change this line:

ws.Range(ws.Cells(r, "C"), ws.Cells(r, "AE")).SpecialCells(xlCellTypeConstants).Offset(-r + 3, 0).Copy

Does that solve it?

I noticed the name change for code author in your posted sheet.