I have adjusted the code to add a third location called "transport" (in
addition to "inside" and "L5")
I have added comments to the code to explain what it is doing
I have used your data and extended it to the right to cover Mon to Fri and
added a few entries
for transport and it worked as expected.
Sub MakeSchedules()
Dim sh As Worksheet, sh1 As Worksheet
Dim i As Long, rw1 As Long, rw2 As Long
Dim rng As Range, cell As Range
Dim rw3 As Long, rng2 As Range
Set sh = ActiveSheet
' check if the schedule sheet is the active sheet
' assumes the label "name" will be in A1
If LCase(sh.Cells(1, 1).Value) <> "name" Then
MsgBox "Schedule isn't the active sheet"
Exit Sub
End If
' get a range reference to the extent of the list of names
' in column 1 of the active sheet.
' same as if you selected A2, then held down the shift key,
' then hit the end key and then the down arrow key
Set rng = sh.Range(sh.Cells(2, 1), sh.Cells(2, 1).End(xlDown))
' Loop through the columns, starting in column C going
' every other column - going day to day
For i = 3 To 11 Step 2
' add a new sheet for that day
Worksheets.Add after:=Worksheets(Worksheets.Count)
' set a reference to it
Set sh1 = ActiveSheet
' name it according to schedule sheet, row1
sh1.Name = sh.Cells(1, i)
' put the same name in A1 of the new sheet
sh1.Cells(1, 1) = sh.Cells(1, i)
' in A2 put "Inside"
sh1.Cells(2, 1) = "Inside"
' I am going to add names to each locatio, but my locations will
' be in rows far enough apart that all names in the schedule could
' be entered under any single location. I will then keep track of
' where the next name is to be entered using rw1 (inside), rw2 (l5), rw3
(transport)
' this allows me to add names in one pass of the data - using a very
simple method
' I could add rows or do multiple passes, but this seemed the simplest to
me
' initialize the locations
rw1 = 3
rw2 = rw1 + rng.Count + 1
rw3 = rw2 + rng.Count + 1
' add labels for l5 and transport
sh1.Cells(rw2, 1) = "l5"
sh1.Cells(rw3, 1) = "Transport"
' adjust to the next blank row
rw2 = rw2 + 1
rw3 = rw3 + 1
' now loop through the list of names and
' use the data from the column I am processing
' and from the list of names. The "i" variable indicates
' which column from the schedule I am processing
For Each cell In rng
If LCase(cell.Offset(0, i)) = "inside" Then
' write the time on the new sheet
sh1.Cells(rw1, 1) = cell.Offset(0, i - 1).Value
sh1.Cells(rw1, 1).NumberFormat = "hh:mm"
' write the name on the new sheet
sh1.Cells(rw1, 2).Value = cell
' adjust the location to write the next name
rw1 = rw1 + 1
ElseIf LCase(cell.Offset(0, i)) = "l5" Then
sh1.Cells(rw2, 1) = cell.Offset(0, i - 1).Value
sh1.Cells(rw2, 1).NumberFormat = "hh:mm"
sh1.Cells(rw2, 2).Value = cell
rw2 = rw2 + 1
ElseIf LCase(cell.Offset(0, i)) = "transport" Then
sh1.Cells(rw3, 1) = cell.Offset(0, i - 1).Value
sh1.Cells(rw3, 1).NumberFormat = "hh:mm"
sh1.Cells(rw3, 2).Value = cell
rw3 = rw3 + 1
End If
Next
' now delete blank rows that might be between the
' locations. Work from the bottom up so the rows
' locations of subsequent locations are not affected
' (since I am deleting rows)
Set rng2 = sh1.Cells(rw2, 1).End(xlDown)(0)
sh1.Range(sh1.Cells(rw2 + 1, 1), rng2).EntireRow.Delete
Set rng2 = sh1.Cells(rw1, 1).End(xlDown)(0)
sh1.Range(sh1.Cells(rw1 + 1, 1), rng2).EntireRow.Delete
Next
End Sub
