Change code help

J

Jcraig713

Hi. I currently have source data of:

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

And code that does:

Room P1 P2 P3 P4 P5 P6
C5 Alg Alg Alg Alg Alg


I have changed my source data to:
Tchr Period Term CrsCode Section Course Room
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

And now want 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:


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
Next

dstsh.Activate

Application.ScreenUpdating = False


ActiveCell.FormulaR1C1 = "Room"
Range("B1:I1").Select
Selection.Interior.ColorIndex = xlNone
Range("B1").Select
ActiveCell.FormulaR1C1 = "Period 1"
Selection.AutoFill Destination:=Range("B1:I1"), Type:=xlFillDefault
Range("B1:I1").Select
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Cells.EntireColumn.AutoFit
Selection.RowHeight = 36
Range("A1").Select
Selection.EntireRow.Insert
Range("A2:I2").Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A3:A71").Select
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Columns("A:A").EntireColumn.AutoFit
Range("B1:I1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "Grid Master Schedule By Room"
Range("B1:I1").Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Range("A1:I70").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A2:A70").Select
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Range("B2:I2").Select
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Range("A1:I1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A2:I2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With ActiveSheet.PageSetup
.PrintTitleRows = "$2:$2"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 80
.PrintErrors = xlPrintErrorsDisplayed

Rows("3:3").Select
ActiveWindow.FreezePanes = True
Range("B3").Select

End With


Application.ScreenUpdating = True

End Sub


Thanks in advance fro yoru help.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

help needed with borders 2
Hlp! Adv Filter - Non-Contiguous rows don't copy 11
Macro to sort, format, sum, a dynamic set of data 2
Formatting stop when reach blank cell 6
Reformat Data 2
Border formatting row of cells 22
How to rewrite this code? (Second half) 1
Help with macro 1

Top