Matrix conversion into rows

[sinhamp]

Hi all,

I want to automatically convert (using macros for e.g.) a matrix into
rows of data.

The matrix is simple with row headings and column headings, and "1" in
various cells. E.g.:
RData1 RData2 RData3 ... RDataN
CData1 1 1
CData2 1
CData3 1
....
CDataM 1

The "1" indicates that CData1 applies to RData1 and RData2, but not to
RData3, and so on...

The output post conversion should look like:

RData1 COL2 CData1
COL2 CData3
COL2 CDataM
RData2 COL2 CData1
COL2 CData2
....and so on...

COL2 is a fixed formula that is the same in each row. The output
should be on a new sheet.

Is this possible using Excel macros or VBA code? I have tried some
approaches but have been unsuccessful :-(

Any help will be much appreciated.

Thx,
sinhamp

 

[Dave Peterson]

This will do something very close.

Option Explicit
Sub testme()

Dim curWks As Worksheet
Dim newWks As Worksheet

Dim FirstCol As Long
Dim LastCol As Long
Dim FirstRow As Long
Dim LastRow As Long

Dim iCol As Long
Dim iRow As Long
Dim oRow As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
FirstCol = 2
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

FirstRow = 2
oRow = 1
For iCol = FirstCol To LastCol
LastRow = .Cells(.Rows.Count, iCol).End(xlUp).Row
For iRow = FirstRow To LastRow
If .Cells(iRow, iCol).Value <> "" Then
newWks.Cells(oRow, 1).Value = .Cells(1, iCol).Value
newWks.Cells(oRow, 2).Value = "Col2"
newWks.Cells(oRow, 3).Value = .Cells(iRow, 1).Value
oRow = oRow + 1
End If
Next iRow
Next iCol
End With

End Sub

But I wouldn't leave those cells in Column A empty if I were you. By having the
values in the cells, it really makes sorts/pivottables/subtotals a lot easier.

So don't use this version--unless absolutely necessary!

Option Explicit
Sub testme2()

Dim curWks As Worksheet
Dim newWks As Worksheet

Dim FirstCol As Long
Dim LastCol As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstTime As Boolean

Dim iCol As Long
Dim iRow As Long
Dim oRow As Long

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
FirstCol = 2
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

FirstRow = 2
oRow = 1
For iCol = FirstCol To LastCol
LastRow = .Cells(.Rows.Count, iCol).End(xlUp).Row
FirstTime = True
For iRow = FirstRow To LastRow
If .Cells(iRow, iCol).Value <> "" Then
If FirstTime = True Then
newWks.Cells(oRow, 1).Value = .Cells(1, iCol).Value
FirstTime = False
End If
newWks.Cells(oRow, 2).Value = "Col2"
newWks.Cells(oRow, 3).Value = .Cells(iRow, 1).Value
oRow = oRow + 1
End If
Next iRow
Next iCol
End With

End Sub