Rearrange Data

[Jcraig713]

Hello. I have source data numbering about 2500 records as shown below:

A B C D E F G
Rm Period Term crscode sec course teacher
A1 2 HS1 HSPE110 1 Health Koenings
A1 3 HS1 HSPE110 2 Health Koenings
A1 4 HS1 HSPE110 3 Health Koenings
A1 6 HS1 HSPE110 4 Health Koenings
A1 7 HS1 HSPE110 5 Health Koenings
A2 2 HS1 HSSP181 1 Geography Moriconi
A2 3 HS1 HSSP220 1 English10 S1 Moriconi
A2 7 HS1 HSSP380 1 History S1 Moriconi
A3 2 HS1 HSCT100 2 Business Morton
A3 5 HS1 HSCT100 4 Business Morton
A3 6 HS1 HSCT210 1 Busin Mgmt Morton
A3 7 HS1 HSCT100 5 Business Morton

I need to re-order the data so the data shows like the following; one room
to many classes in periods on one record line:

Room P1 P2 P3 P4 P5 P6 P7
P8
A1 Health Health Health Health Health
A2 Geog Engl10 Hist
A3 Busin Busin BusMgt Busin

Any help would be greatly appreciated.

 

[Joel]

Try this code. Change source and dest sheet names as required.


Sub SortByRooms()
Set SourceSht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")


With DestSht
.Range("A1") = "Room"
For Period = 1 To 8
.Cells(1, Period + 1) = "P" & Period
Next Period
End With

NewRow = 2
RowCount = 2

With SourceSht
Do While .Range("A" & RowCount) <> ""
Room = .Range("A" & RowCount)
Period = .Range("B" & RowCount)
Course = .Range("F" & RowCount)

With DestSht
'check if room already exists
Set c = .Columns("A").Find(what:=Room, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & NewRow) = Room
.Cells(NewRow, Period + 1) = Course
NewRow = NewRow + 1
Else
'check if room already assigned
If .Cells(c.Row, Period + 1) <> "" Then
MsgBox ("All ready in use Room : " & Room & " , Period: " &
Period)
Else
.Cells(c.Row, Period + 1) = Course
End If

End If

End With
RowCount = RowCount + 1
Loop
End With

End Sub

 

[Patrick Molloy]

nice and simple this one

Option Explicit
Dim wsSource As Worksheet
Dim wsTarget As Worksheet

Sub Tabulate()

Dim cell As Range
Dim rm As String
Dim period As Long
Dim course As String
Dim rw As Long

Set wsSource = ActiveSheet
Set wsTarget = Worksheets.Add()

Set cell = wsSource.Range("A2")

Do Until cell.Value = ""
rm = cell.Value
period = cell.Offset(, 1).Value
course = cell.Offset(, 5).Value

rw = checkrow(rm)
wsTarget.Cells(rw, period + 1) = course

Set cell = cell.Offset(1)
Loop
End Sub
Function checkrow(rm As String)
On Error Resume Next
checkrow = WorksheetFunction.Match(rm, wsTarget.Range("A1:A1000"),
False)
If checkrow = 0 Then
checkrow = wsTarget.Range("A65000").End(xlUp).Row + 1
wsTarget.Range("A65000").End(xlUp).Offset(1) = rm
End If
End Function


mail me direct and I'll send the workbook

 

[Jcraig713]

Patrick, thanks! Do you think we could take this a step further? You
indicated to mail you direct but I do not know how to see your email address?
So I thought I would respond here.

I would like to have period 1, 2, 3 etc. along the top for column headers.

Also, in some instances, there are two classes scheduled for the same
period. In some cases this is ok (more than one class is offered at a time
in a room) and in other instances, it should not be occurring.

In the cells where the course name is listed by period to the right of the
room number, can those instances of multiplecourses all be listed in the
same cell perhaps seperated by commas or other method, then highlighted in
red to stand out?

Then, in those cells that are null or blank, can those blank cells be filled
with gray highlight to stand out visually as an open room to schedule classes
in? My intention is to see what course is scehduled where, which courses my
be duplicated in a period, and open spots I have to move the class to.

I cannot tell you how much this is helping me. Days of work of cross
referencing reports is replaced. I just hope we can take this a step
further. Thanks.

 

[keiji kounoike]

This is almost same as Joel's code, but try this.
First, select your data sheet and run the macro below

Sub talbleset()
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 = 6 ' 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

End Sub


Keiji

 

[Jcraig713]

Yes thanks. It works beautifully. I am very appreciative of your help.

I ask this all the time of people who answer my posts with such great
assistance. I so want to learn how to do this myself as I feel I am
constantly posting and mooching off people. I would like to someday be able
to give back. How does one start to learn to do this type of stuff. I have
so many ideas of things I want to do to make my job easier using excel like
this but I have no idea how to start thinking to create this type of code. I
have books I have read and I understand the excersizes when I am doing them
but when I come up with a "project" like this one, I just have no
understanding of how to set it up and to move forward. Any suggestions for
someone who is willing to learn?

 

[keiji kounoike]

My start to learn VBA is the same as you, just for making my job easier.
you said you had many ideas of things, then i think you have a good
starting point to be familiar with VBA. all you have to do is that you
just find the way to translate what you are doing manually into VBA.
Most important thing, i think, is to learn how to use debugger. as many
programme as you write by yourself, you sure come to be able to write
more efficient code. To read good programme might to be a big help.

Keiji