snippets/microsoft/ms-office/excel/macros/MatrixToList.vba

Public mtrx, dbase, v As String
Public ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Integer

Sub Matrix()

' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
' The Macro was turned into an "add in" by Thirsa Kraaijenbrink
' You are welcome to redistribute this macro, but if you make substantial
' changes to it, please indicate so in this section along with your name.
' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
' The Macro assumes the matrix begins in the upper left cells of the spreadsheet.
' The conversion allows for multiple header rows and columns.
' Because of a quirk in how Excel handles blanks and zeroes I had to create two options:
' one which includes zero and negative values and empty cells,
' and one which ignores these - sorry for any inconvenience.

'-----------------------------------------------------------------------------
' This section asks about data types, row headers, and column headers

all = MsgBox("Include zero, negative, and empty cells?", vbYesNoCancel)
rowz = InputBox("How many HEADER ROWS?", "Header Rows & Columns")
colz = InputBox("How many HEADER COLUMNS?", "Header Rows & Columns")

'-----------------------------------------------------------------------------
' This section allows the user to provide field (column) names for the new spreadsheet

Dim Arr(10) As Variant
newcol = 1
For r = 1 To rowz
    Arr(newcol) = InputBox("Field name for row " & r)
    newcol = newcol + 1
Next
For c = 1 To colz
    Arr(newcol) = InputBox("Field name for column " & c)
    newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol

'-----------------------------------------------------------------------------
' This section creates the new spreadsheet and names it

mtrx = ActiveSheet.Name
Sheets.Add
dbase = "DB of " & mtrx
ActiveSheet.Name = dbase

'-----------------------------------------------------------------------------
'This section determines how many rows and columns the matrix has

dun = False
rotot = rowz + 1
Do
    If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
        rotot = rotot + 1
    Else
        dun = True
    End If
Loop Until dun
rotot = rotot - 1

dun = False
coltot = colz + 1
Do
    If (Sheets(mtrx).Cells(1, coltot) > 0) Then
        coltot = coltot + 1
    Else
        dun = True
    End If
Loop Until dun
coltot = coltot - 1

'-----------------------------------------------------------------------------
'This section writes the new field names to the new spreadsheet

For newcol = 1 To v
    Sheets(dbase).Cells(1, newcol) = Arr(newcol)
Next

'-----------------------------------------------------------------------------
'This section actually does the conversion

Dim tot As Long
tot = 0
newro = 2
For col = (colz + 1) To coltot
    For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
        If ((Sheets(mtrx).Cells(ro, col) > 0) Or (all = 6)) Then
            tot = tot + 1
            newcol = 1
            For r = 1 To rowz            'the next line copies the row headers
                Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
                newcol = newcol + 1
            Next
            For c = 1 To colz         'the next line copies the column headers
                Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
                newcol = newcol + 1
            Next                                'the next line copies the data
            Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
            newro = newro + 1
        End If
    Next
Next

'-----------------------------------------------------------------------------
'This section displays a message box with information about the conversion

book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"

MsgBox (book & head & cels)

End Sub