Try the following code: test it with a copy of your workbook first, just in
case. The code goes into a regular module: press [Alt]+[F11] to open the VB
Editor then choose Insert | Module from its menu. Copy and paste this code
into it. Edit the definitions for the Const values I've provided to tailor
it to your actual workbook. As currently written, other than the worksheet
names involved, it is set up to work with data laid out as you've shown it
here: names in column A starting at row 2, header row in row 1, dates
starting in column C, JOBS named in B. Any of that can be changed, just
one "MUST" that really needs to be followed: the dates must start in a column
to the right of the Names and JOB columns. I've actually tested this here
and it appears to do what you've requested.
Sub BuildByJobsSheet()
'assumptions:
' names are in column A
' Jobs are in column B
' hours worked on a job begin in column C
' dates begin in C1 and go across sheet unbroken
' dates MUST begin AFTER names & jobs
'change these Const values to match sheet names
'that are actually in your workbook
'name of sheet with list to work from
Const srcSheetName = "ByHours"
'name for new arrangement sheet
'sheet does not have to exist
'if it doesn't, it will be created
Const destSheetName = "ByJobs"
'change these to allow for different source sheet
'layouts.
Const nameColumn = "A"
Const jobColumn = "B"
Const firstDateColumn = "C"
' row with dates in it
Const dateRow = 1
' row with first name in it
' MUST be greater than 1
Const firstNameRow = 2
Dim srcSheet As Worksheet
Dim srcRange As Range
Dim srcLastRow As Long
Dim srcLastCol As Long
Dim srcBase As Range
Dim destSheet As Worksheet
Dim destRange As Range
Dim destBase As Range
Dim destLastRow As Long
Dim maxRows As Long
Dim tmpAddress As String
Dim anyCell As Object
Dim ListOfNames() As String
Dim NamesLoop As Long ' loop counter
Dim dateStartOffset As Long
Dim cOffset As Long ' loop counter for date columns
Dim rOffset As Long ' loop counter for names
Dim nameMatchFoundFlag As Boolean
'get proper value for last possible row# on sheet
If Val(Left(Application.Version, 2)) < 12 Then
'in pre-2007 version of Excel
maxRows = Rows.Count
Else
'in Excel 2007 (or later)
maxRows = Rows.CountLarge
End If
Set srcSheet = Worksheets(srcSheetName)
tmpAddress = Range(nameColumn & firstNameRow).Offset(-1, 0).Address
Set srcBase = srcSheet.Range(tmpAddress)
'test if destination sheet exists
On Error Resume Next
Set destSheet = Worksheets(destSheetName)
If Err <> 0 Then
'sheet doesn't exist
'create it
Err.Clear
On Error GoTo 0
srcSheet.Copy after:=Sheets(srcSheet.Name)
ActiveSheet.Name = "ByJob"
Set destSheet = ActiveSheet
End If
On Error GoTo 0
'prepare to rebuild new sheet
destSheet.Cells.Clear
tmpAddress = "A" & dateRow & ":" & _
srcSheet.Range("A" & dateRow).End(xlToRight).Address
Set srcRange = srcSheet.Range(tmpAddress)
srcLastCol = srcRange.Columns.Count
If srcLastCol < 3 Then
'nothing to do, no dates on source sheet!
Set srcRange = Nothing
Set srcSheet = Nothing
Exit Sub
End If
Application.ScreenUpdating = False
Set destRange = destSheet.Range(tmpAddress)
destRange.Value = srcRange.Value
destLastRow = 1
tmpAddress = Range(nameColumn & firstNameRow).Offset(-1, 0).Address
Set destBase = destSheet.Range(tmpAddress)
'get unique names from source sheet, column A
'and place into dynamic array ListOfNames()
'initialize and seed the array
ReDim ListOfNames(1 To 1)
ListOfNames(1) = srcSheet.Range(nameColumn & firstNameRow).Value
'assume continuous list of names
srcLastRow = srcSheet.Range(nameColumn & _
maxRows).End(xlUp).Row
'another test for anything to do
If srcLastRow < firstNameRow Then
'nothing to do, no names on source sheet!
Set srcRange = Nothing
Set srcSheet = Nothing
Application.ScreenUpdating = True
Exit Sub
End If
'pick up names and place one copy of
'each unique name into array ListOfNames()
Set srcRange = srcSheet.Range(nameColumn & firstNameRow & ":" _
& nameColumn & srcLastRow)
For Each anyCell In srcRange
nameMatchFoundFlag = False
For NamesLoop = LBound(ListOfNames) To _
UBound(ListOfNames)
If UCase(Trim(anyCell.Value)) = _
UCase(Trim(ListOfNames(NamesLoop))) Then
nameMatchFoundFlag = True
Exit For
End If
Next
If Not (nameMatchFoundFlag) Then
'new name, add to list
'if the cell is not empty
If Not IsEmpty(anyCell) Then
ReDim Preserve ListOfNames(1 To _
UBound(ListOfNames) + 1)
ListOfNames(UBound(ListOfNames)) = anyCell.Value
End If ' empty cell test
End If ' new name test
Next
'firstDateColumn
dateStartOffset = _
Range(firstDateColumn & 1).Column - srcBase.Column
'
'The real work begins
'for each name in ListOfNames()
'find name on source sheet, and for each
'date column, find out if they worked on a job
'and if they did, build up string JobsWorked
'to be placed on the destination sheet in proper column
'
For NamesLoop = LBound(ListOfNames) To UBound(ListOfNames)
destBase.Offset(NamesLoop, 0) = ListOfNames(NamesLoop)
For rOffset = 1 To srcLastRow - 1
For cOffset = dateStartOffset To srcLastCol - 1
'test if names match
If UCase(Trim(srcBase.Offset(rOffset, 0))) = _
UCase(Trim(ListOfNames(NamesLoop))) Then
'test if hours > 0
If srcBase.Offset(rOffset, cOffset) > 0 Then
destBase.Offset(NamesLoop, cOffset) = _
destBase.Offset(NamesLoop, cOffset) & " " & _
srcBase.Offset(rOffset, 1).Value
End If 'hours worked test
End If ' name match test
Next ' cOffset loop end
Next ' rOffset loop end
Next ' NamesLoop loop end
'get rid of JOBS column in new sheet
destSheet.Range(jobColumn & 1).EntireColumn.Delete
'release resources
Set srcRange = Nothing
Set srcBase = Nothing
Set srcSheet = Nothing
Set destBase = Nothing
Set destRange = Nothing
Set destSheet = Nothing
Application.ScreenUpdating = True
End Sub
ellebelle said:
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
