Materials       Person1     Person2
---------       ---------   ---------
563718          20          40
837563          15          35

Person          Materials   Data
---------       ---------   ---------
Person1         563718      20
Person1         837563      15
Person2         563718      40
Person2         837563      35

Option Explicit

Sub MatrixConverter2_3()

'--------------------------------------------------
' This section declares variables for use in the script

Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long
Dim headers(100) As Variant
Dim dun As Boolean


'--------------------------------------------------
' This section sets the script defaults

defaultHeaderRows = 1
defaultHeaderColumns = 2

DefaultRowName = "MyColumnName"

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

UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro

all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro


' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS
rowz = 1
' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows)
' If rowz = vbNullString Then GoTo EndMatrixMacro

colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro


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

selectionCols = Selection.Columns.Count ' get the number of columns in the selection
For r = 1 To selectionCols
    headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names
Next r

colz = colz * 1
columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"

Dim Arr(20) As Variant
newcol = 1
For r = 1 To rowz
    If r = 1 Then RowName = DefaultRowName
    Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName)
    If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
    newcol = newcol + 1
Next
For c = 1 To colz
    ColName = headers(c)
    Arr(newcol) = InputBox("Field name for column " & c, , ColName)
    If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
    newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol

'--------------------------------------------------
' This section creates the new spreadsheet, names it, and color codes the new worksheet tab

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

'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
    If Len(dbase) > 28 Then dbase = Left(dbase, 28)


'--------------------------------------------------
' This section checks if the proposed worksheet name
'  already exists and appends adds a sequential number
'  to the name
    Dim sheetExists As Variant
    Dim Sheet As Worksheet
    Dim iName As Integer

    Dim dbaseOld As String
    dbaseOld = dbase    ' save the original proposed name of the new worksheet

    iName = 0

    sheetExists = False
CheckWorksheetNames:

    For Each Sheet In Worksheets    ' loop through every worksheet in the workbook
        If dbase = Sheet.Name Then
            sheetExists = True
            iName = iName + 1
            dbase = Left(dbase, Len(dbase) - 1) & " " & iName
            GoTo CheckWorksheetNames
            ' Exit For
        End If
    Next Sheet


'--------------------------------------------------
' This section notify the user if the proposed
' worksheet name is already being used and the new
' worksheet was given an alternate name

    If sheetExists = True Then
        MsgBox "The worksheet '" & dbaseOld & "' already exists.  Renaming to '" & dbase & "'."
    End If


'--------------------------------------------------
' This section creates and names a new worksheet
    On Error Resume Next    'Ignore errors
        If Sheets("" & Range(dbase) & "") Is Nothing Then   ' If the worksheet name doesn't exist
            ActiveSheet.Name = dbase    ' Rename newly created worksheet
        Else
            MsgBox "Cannot name the worksheet '" & dbase & "'.  A worksheet with that name already exists."
            GoTo EndMatrixMacro
        End If
    On Error GoTo 0         ' Resume normal error handling

    Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab


'--------------------------------------------------
' This section turns off screen and calculation updates so that the script
' can run faster.  Updates are turned back on at the end of the script.
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False


'--------------------------------------------------
'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

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   'DCB modified ">0" to be "<>0" to exclude blank and zero cells
            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"


'--------------------------------------------------
' This section turns screen and calculation updates back ON.
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


MsgBox (book & head & cels)


'--------------------------------------------------
' This is an end point for the macro

EndMatrixMacro:

End Sub

Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long

'--------------------------------------------------
' This section declares variables for use in the script

Dim book
Dim head
Dim cels
Dim mtrx
Dim dbase
Dim v
Dim UserReady
Dim columnsToCombine
Dim RowName
Dim DefaultRowName
Dim DefaultColName1
Dim DefaultColName2
Dim ColName As String

Dim defaultHeaderRows
Dim defaultHeaderColumns
Dim c
Dim r
Dim selectionCols
Dim ro
Dim col
Dim newro
Dim newcol
Dim rotot
Dim coltot
Dim all
Dim rowz
Dim colz
Dim tot As Long

Dim headers(100) As Variant
Dim dun As Boolean

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

UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro

Dim UserReady As VbMsgBoxResult

If MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel) <> vbYes Then Exit Sub

all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro

If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then

If Sheets(mtrx).Cells(ro, col) <> 0 Or Not IsExcludingZeroAndEmpty Then

colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro

If StrPtr(colz) = 0 Then Exit Sub

colz = colz * 1

columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"

If Not IsNumeric(colz) Then 'user is playing smartypants

'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
    If Len(dbase) > 28 Then dbase = Left(dbase, 28)

' Maximum length allowed for a sheet name is 31 characters
    If Len(dbase) > 28 Then dbase = Left(dbase, 28)

Private Const SHEETNAME_MAXLENGTH As Integer = 28 ' actually it's 31, but we're keeping a little buffer to append a digit if needed

If Len(dbase) > SHEETNAME_MAXLENGTH Then dbase = Left(dbase, SHEETNAME_MAXLENGTH)

'--------------------------------------------------
' This section checks if the proposed worksheet name
'  already exists and appends adds a sequential number
'  to the name

'--------------------------------------------------
' This section belongs in its own procedure or function

columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"

If (Sheets(mtrx).Cells(1, coltot) > 0) Then

If Sheets(mtrx).Cells(1, coltot) > 0 Then

If ((Sheets(mtrx).Cells(((((1)))), ((coltot)))) > (((0)))) Then

mtrx = ActiveSheet.Name

If (Sheets(mtrx).Cells(rotot, 1) > 0) Then

Dim matrix as Worksheet
Set matrix = ActiveSheet

If matrix.Cells(rotot, 1) > 0 Then

Sheets.Add After:=ActiveSheet

Dim dbase As Worksheet
Set dbase = matrix.Parent.Sheets.Add(After:=matrix)

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

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

v = newcol

For newcol = 1 To v

Dim sheetExists As Variant
    Dim Sheet As Worksheet
    Dim iName As Integer

    Dim dbaseOld As String
    dbaseOld = dbase    ' save the original proposed name of the new worksheet

    iName = 0

    sheetExists = False
CheckWorksheetNames:

    For Each Sheet In Worksheets    ' loop through every worksheet in the workbook
        If dbase = Sheet.Name Then
            sheetExists = True
            iName = iName + 1
            dbase = Left(dbase, Len(dbase) - 1) & " " & iName
            GoTo CheckWorksheetNames
            ' Exit For
        End If
    Next Sheet

Private Function GetUniqueSheetName(book As Workbook, ByVal proposed As String) As String
    Dim existing As New Scripting.Dictionary
    Dim sheet As Worksheet

    For Each sheet In book.Worksheets
        existing.Add sheet.Name, vbNull
    Next

    Dim unique As String
    unique = proposed
    Dim suffix As Long
    Do
        If Not existing.Exists(unique) Then
            GetUniqueSheetName = unique
            Exit Function
        End If
        suffix = suffix + 1
        unique = proposed & " " & suffix
    Loop
End Function

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

With Sheets(mtrx)
    'Number of rows in column A
    rotot = .Range("A" & .Rows.Count).End(xlUp).Row
    'Number of columns in row 1
    coltot = .Range("XFD" & 1).End(xlToLeft).Column
End With

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

Dim matixValues As Variant
With Sheets(mtrx)
    matixValues = .Range(.Cells(rowz + 1, colz + 1), .Cells(rowtot, coltot)).Value
End With

For col = LBound(matixValues, 2) To UBound(matixValues, 2)
    For ro = LBound(matixValues, 1) To UBound(matixValues, 1)
        If matixValues(ro, col) <> 0 Or all = vbNo Then
        '...
        End If
    Next
Next

InputBox("How many HEADER ROWS?" & vbNewLine ...

If colz = vbNullString Then GoTo EndMatrixMacro

On Error GoTo CleanExit
    Dim calcState As XlCalculation

    calcState = Application.Calculation
    Application.Calculation = xlCalculationManual
    '...
CleanExit:
    Application.Calculation = calcState
End Sub

.Offset(rowOffset:=-1, columnOffset:=0)

Dim sheetExists As Variant
Dim Sheet As Worksheet
Dim iName As Integer

`... nothing to do with iName or sheetExists here.
iName = 0
sheetExists = False

Dim foo As Variant
Debug.Print foo = False  'Prints True