Break down, rebuild a matrix

[Possum Stu]

This may not be a question so much about programming as it is about
technique.

To start with, I am given a simple 2D grid that makes up a schedule for
performing the same process on a group of items.

For column heads use Step A, Step B, Step C, and Step D. For row heads
use the object for which the step must be taken: Item 1, Item 2, Item
3, through Item 10. Within this grid is data: the due dates (Item 2
must have Step C completed by 5/1, Step D by 5/3, etc.).

I've written a script that runs through every data cell and copies a
reference to a database-like table on a new worksheet that reports the
full value of the data. Thus my new sheet has "Item," "Date," and
"Task" as the column heads and sets out all of the information on a
long narrow ribbon. (For example, one cell on the original sheet that
reads "5/10" is written out to three cells with values Item 6, Step 4,
and 5/10 respectively.) Now I can sort this by date and see that, say,
on 5/3 Step 1 of Item 3 must be done, Step 2 of Item 2 must done, and
so on. And by using references, if the first sheet is updated the list
is too.

Question: Can I use this ribbon of dates to build a new matrix? If so,
how?

For example, one client wants to have a matrix where the column heads
are Steps and the row heads are Dates, and the various items due appear
in the data. Is this kind of transposition feasible without manual
assistance?

 

[Toppers]

Hi,
Try this.

First routine transposes data from matrix to list with extra column D which
contains a number representing a task i.e. Task A =1, Task B=2 ...


The second routine tranposes the list into a Task by Date matrix with Items
as data. It currently assumes that there is only one item for a given task on
a given date. If this is not the case, then we need to add logic to
accommodate multiple items in a task having the same date; one way is to
"add" the items into a single cell e.g cell would contain "Item 1, Item 2"


HTH


Sub Transpose_2Dto1D()
Dim r As Integer, c As Integer, n As Integer, hdg As Variant
Dim iLastRow As Integer, iLastCol As Integer, i As Integer
Dim InRng As Range, StepRng As Range, ItemRng As Range, BigRng As Range
Dim TaskRng As Range, OutRng As Range

Worksheets("Sheet1").Activate
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Set ItemRng = Cells(2, 1).Resize(iLastRow - 1, 1)
Set TaskRng = Cells(2, iLastCol + 1).Resize(iLastRow - 1, 2)
Set OutRng = Worksheets("Sheet2").Range("A2")

hdg = Array("Item", "Date", "Task", "ID")
For i = 0 To 3
Worksheets("Sheet2").Cells(1, i + 1) = hdg(i)
Next i

For n = 2 To iLastCol
TaskRng = Cells(1, n)
TaskRng.Offset(0, 1) = n - 1 ' Add Task ID number (Task A=1, Task B=2 ...
Set StepRng = Cells(2, n).Resize(iLastRow - 1, 1)
Set BigRng = Application.Union(ItemRng, StepRng, TaskRng)
BigRng.Copy OutRng
Set OutRng = OutRng.Offset(iLastRow - 1, 0)
Next n
TaskRng = ""
Sub TaskByDate()

Dim myCell As Range, InRng As Range, OutRng As Range, cell As Range
Dim r As Long, FindDate As Date, iLastRow As Long, iLastr As Integer, n As
Integer
Dim i As Integer
Dim wsIn As Worksheet, wsOut As Worksheet

Set wsIn = Worksheets("Sheet2") ' Contains List
Set wsOut = Worksheets("Sheet3") ' Contains new matrix

wsIn.Select
Columns("A").Select ' Sort Data
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal

n = Application.Max(Range("D")) ' Find Max number of tasks
wsOut.Cells(1.1) = "Date"
For i = 1 To n
wsOut.Cells(1, i + 1) = "Task " & i ' Set column Headings
Next i

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set OutRng = Worksheets("Sheet3").Range("A2")

r = 2

With wsIn
Do While r <= iLastRow

FindDate = .Cells(r, "B")
Set myCell = .Range("B:B").Find(FindDate) ' Find first amd last
cells with same date
iLastr = myCell.Row + Application.CountIf(.Range("B:B"), FindDate) - 1

Set InRng = Range(myCell, .Cells(iLastr, "B")) ' Range with same date
OutRng = FindDate
For Each cell In InRng
n = cell.Offset(0, 2).Value ' Task Number ....
OutRng.Offset(0, n) = cell.Offset(0, -1) ' Item
Next

r = iLastr + 1 ' next input row ....
Set OutRng = OutRng.Offset(1, 0) ' Set ouput to next row ....

Loop

End With

End Sub

 

[Possum Stu]

When I compile the first routine, I get a run-time error 1004: "Method
'Union' of object '_Application' failed." This is puzzling because your
syntax matches exactly that offered by the VBA Help screens. I tried
altering the range descriptions to "Range(ItemRng), Range(StepRng),
Range(TaskRng)" with and without quotes but no go. Could there be a
problem with the value of TaskRng as it gets assigned values?

Also, the assumption that there is only one task for a given date would
make life easier, but would hardly keep us in business. Ultimately
this tool is going to be used to merge over a hundred single-task
worksheets into a tracking master list, and then that master list will
be broken up into daily or weekly chunks to help forecast our workload.

I'm working out the method of adding multiple items to a cell, but for
purposes of a clear display, how does one (through VBA) add items to a
cell separated by an internal cell line break?