MatrixToList.vba 4.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116
  1. Public mtrx, dbase, v As String
  2. Public ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Integer
  3. Sub Matrix()
  4. ' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
  5. ' The Macro was turned into an "add in" by Thirsa Kraaijenbrink
  6. ' You are welcome to redistribute this macro, but if you make substantial
  7. ' changes to it, please indicate so in this section along with your name.
  8. ' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
  9. ' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
  10. ' The Macro assumes the matrix begins in the upper left cells of the spreadsheet.
  11. ' The conversion allows for multiple header rows and columns.
  12. ' Because of a quirk in how Excel handles blanks and zeroes I had to create two options:
  13. ' one which includes zero and negative values and empty cells,
  14. ' and one which ignores these - sorry for any inconvenience.
  15. '-----------------------------------------------------------------------------
  16. ' This section asks about data types, row headers, and column headers
  17. all = MsgBox("Include zero, negative, and empty cells?", vbYesNoCancel)
  18. rowz = InputBox("How many HEADER ROWS?", "Header Rows & Columns")
  19. colz = InputBox("How many HEADER COLUMNS?", "Header Rows & Columns")
  20. '-----------------------------------------------------------------------------
  21. ' This section allows the user to provide field (column) names for the new spreadsheet
  22. Dim Arr(10) As Variant
  23. newcol = 1
  24. For r = 1 To rowz
  25. Arr(newcol) = InputBox("Field name for row " & r)
  26. newcol = newcol + 1
  27. Next
  28. For c = 1 To colz
  29. Arr(newcol) = InputBox("Field name for column " & c)
  30. newcol = newcol + 1
  31. Next
  32. Arr(newcol) = "Data"
  33. v = newcol
  34. '-----------------------------------------------------------------------------
  35. ' This section creates the new spreadsheet and names it
  36. mtrx = ActiveSheet.Name
  37. Sheets.Add
  38. dbase = "DB of " & mtrx
  39. ActiveSheet.Name = dbase
  40. '-----------------------------------------------------------------------------
  41. 'This section determines how many rows and columns the matrix has
  42. dun = False
  43. rotot = rowz + 1
  44. Do
  45. If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
  46. rotot = rotot + 1
  47. Else
  48. dun = True
  49. End If
  50. Loop Until dun
  51. rotot = rotot - 1
  52. dun = False
  53. coltot = colz + 1
  54. Do
  55. If (Sheets(mtrx).Cells(1, coltot) > 0) Then
  56. coltot = coltot + 1
  57. Else
  58. dun = True
  59. End If
  60. Loop Until dun
  61. coltot = coltot - 1
  62. '-----------------------------------------------------------------------------
  63. 'This section writes the new field names to the new spreadsheet
  64. For newcol = 1 To v
  65. Sheets(dbase).Cells(1, newcol) = Arr(newcol)
  66. Next
  67. '-----------------------------------------------------------------------------
  68. 'This section actually does the conversion
  69. Dim tot As Long
  70. tot = 0
  71. newro = 2
  72. For col = (colz + 1) To coltot
  73. For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
  74. If ((Sheets(mtrx).Cells(ro, col) > 0) Or (all = 6)) Then
  75. tot = tot + 1
  76. newcol = 1
  77. For r = 1 To rowz 'the next line copies the row headers
  78. Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
  79. newcol = newcol + 1
  80. Next
  81. For c = 1 To colz 'the next line copies the column headers
  82. Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
  83. newcol = newcol + 1
  84. Next 'the next line copies the data
  85. Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
  86. newro = newro + 1
  87. End If
  88. Next
  89. Next
  90. '-----------------------------------------------------------------------------
  91. 'This section displays a message box with information about the conversion
  92. book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
  93. head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
  94. cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"
  95. MsgBox (book & head & cels)
  96. End Sub