Reformat Data

[Jcraig713]

Hi. I need to reorder my data based on the code below. I currently have
source data of:

A B C D E F G
RoomPeriod Term CrsCode Section Course Tchr
Craig 1 HS1 HSS1 2 Algebra C5
Craig 2 HS1 HSS1 6 Algebra C5
Craig 3 HS1 HSS1 1 Algebra C5
Craig 4 HS1 HSS1 4 Algebra C5
Craig 5 HS1 HSS1 5 Algebra C5

I need the results to be this; teacher along the left and course and room
number in the cells:

Tchr P1 P2 P3 P4 P5 P6
Craig Alg C-5 Alg C-5 Alg C-5 Alg C-5 Alg C-5


Can you help amend my code below to do this. I am not sure how to make the
course name and room number merge to one field in the grid from two cells:


Option Explicit
Dim wsSource As Worksheet
Dim wsTarget As Worksheet

Sub CreateGridRprt()
Dim srcsh As Worksheet, dstsh As Worksheet
Dim pcell As Range, tcell As Range
Dim pmax As Long, i As Long

Set srcsh = ActiveSheet
pmax = Application.Max(Columns("B"))
Set dstsh = Worksheets.Add(after:=srcsh)

Range("A1") = srcsh.Range("A1")
For i = 1 To pmax
Cells(1, i + 1) = "P" & i
Next

srcsh.Activate
Set pcell = Range("A2")
Do While (pcell <> "")
Set tcell = dstsh.Columns("A") _
.Find(pcell.Value, LookIn:=xlValues, lookat:=xlWhole)
If tcell Is Nothing Then
Set tcell = dstsh.Cells(Cells.Rows.Count, "A") _
.End(xlUp).Cells(2, 1)
tcell = pcell
tcell.Cells(1, pcell.Cells(1, "B") + 1) = _
pcell.Cells(1, "F")
Else
If tcell.Cells(1, pcell.Cells(1, "B") + 1) <> "" Then
tcell.Cells(1, pcell.Cells(1, "B") + 1) = _
tcell.Cells(1, pcell.Cells(1, "B") + 1) & _
", " & Chr(10) & pcell.Cells(1, "F")
tcell.Cells(1, pcell.Cells(1, "B") + 1). _
Interior.ColorIndex = 44 ' paint yellow
Else
tcell.Cells(1, pcell.Cells(1, "B") + 1) = _
pcell.Cells(1, "F")
End If
End If
Set pcell = pcell(2, "A")
Loop
'paint blank cell with gray color
dstsh.Cells.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 15
'just for adjusting column width
For i = 1 To pmax + 1
If Application.CountA(dstsh.Columns(i)) <> 1 Then
dstsh.Columns(i).ColumnWidth = 20
dstsh.Columns(i).AutoFit
dstsh.Columns(i).ColumnWidth = dstsh.Columns(i).ColumnWidth + 1
End If
Next
'just for adjusting row's height
For Each pcell In dstsh.Range("A1").CurrentRegion
pcell.EntireRow.AutoFit

End Sub


Thanks in advance for your help.

 

[Don Guillett]

If desired, send your file to my address below along with this msg and
a clear explanation of what you want and before/after examples.

 

[Patrick Molloy]

in my demo, i ha rows 2:6 fro Craig, 7:11 John and 12:16 mary

the data is copied to a new sheet
i ignored headings


Option Explicit
Sub Main()
Dim teacher As String
Dim RowIndex As Long
Dim TargetRow As Long
Dim TargetCol As Long
Dim wsThis As Worksheet
Dim wsNew As Worksheet
Set wsThis = ActiveSheet
Set wsNew = Worksheets.Add

TargetRow = 0
RowIndex = 2
With wsThis
Do While .Cells(RowIndex, 1) <> ""

If .Cells(RowIndex, 1) <> teacher Then
TargetRow = TargetRow + 2
teacher = .Cells(RowIndex, 1)
wsNew.Cells(TargetRow, 1) = teacher
End If
TargetCol = .Cells(RowIndex, 2) + 1
wsNew.Cells(TargetRow, TargetCol) = .Cells(RowIndex, "F") & _
" " & .Cells(RowIndex, "G")

RowIndex = RowIndex + 1
Loop

End With
End Sub