Hello,
I have some existing code which I did not write, nor do I have the
expertise to update. Any assistance would be appreciated to add two new
fields of information to my output. The macro code takes multi rows of data
for one person and "flips" the output to be one record per person with
columns of data.
The source data looks like this sorted by teacher, Term and Period (columns
H and I are the new ones added; the code currently looks through column G
only)
A
Faculty NameB
PeriodcC
MarkDefD
CoursecE
SectionnF
CourseG
TermcH
TallyI
SectSizeBargerstock1H13200101Accounting ATM12030Bargerstock4H13200012Intro
to TechnologyTM12430Bargerstock5H13200231Exploring BusinessTM12230
Bargerstock6H13200241Business Mgmt ATM13030Bargerstock1H23200112Accounting B
TM22230Bargerstock2H23200016Intro to
TechnologyTM23030Bargerstock5H23200011Intro
to TechnologyTM23030Bargerstock6H23200251Business Mgmt BTM22730Bargerstock1
H33200014Intro to TechnologyTM33030Bargerstock2H33200015Intro to Technology
TM33030Bargerstock5H33200063Business LawTM33030Bargerstock6H33200261Business
Mgmt CTM31930Bargerstock3N13000201LEADYRH130
The Output Looks Like:
A
Faculty NameB
Period1C
Period2D
Period3E
Period4F
Period5G
Period6H
Period7I
Period8BargerstockAccounting A-Term: TM1,
Accounting B-Term: TM2,
Intro to Technology & -Term: TM3Intro to Technology-Term: TM2,
Intro to Technology -Term: TM3
LEAD-Term: YRH
Not used so Greyed-out
Exploring Business-Term: TM1,
Intro to Technology-Term: TM2,
Business Law-Term: TM3
Business Mgmt A-Term: TM1,
Business Mgmt B-Term: TM2,
Business Mgmt C-Term: TM3
I just want to add column H and I data to the period course listings by
term. So instead of "Term: TM#", just have the display indicate Termcode:
Tally/SectSize.... such as (example): "TM1: 20/30"
My Code is as follows:
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
Dim period As Integer
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)
Select Case pcell.Cells(1, "B")
Case 1 To 8
period = pcell.Cells(1, "B") + 1
Case Else
period = period + 1
End Select
If tcell Is Nothing Then
Set tcell = dstsh.Cells(Cells.Rows.Count, "A") _
.End(xlUp).Cells(2, 1)
tcell = pcell
tcell.Cells(1, period) = _
pcell.Cells(1, "F") & "-" & "Term:" & " " & pcell.Cells(1, "G")
Else
If tcell.Cells(1, period) <> "" Then
tcell.Cells(1, period) = _
tcell.Cells(1, period) & _
", " & Chr(10) & pcell.Cells(1, "F") & "-" & "Term:" & " " & pcell.Cells(1,
"G")
tcell.Cells(1, period). _
Interior.ColorIndex = 44 ' paint yellow
Else
tcell.Cells(1, period) = _
pcell.Cells(1, "F") & "-" & "Term:" & " " & pcell.Cells(1, "G")
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
--
"Your life should not be defined by how you weather the storm rather, how
you dance in the rain"
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
