Arrange Data Matrix into List for Access

  • Thread starter Thread starter ra
  • Start date Start date
R

ra

Hello,

Using Access for a number of calculation and have a lot of source data
in this format:

Name OCT NOV DEC
A 0 1 1
B 1 0.5 0
C 1 0 0
D 1 1 1


That I need to rearrange into this format:

A OCT 0
B OCT 1
C OCT 1
D OCT 1
A NOV 1
B NOV 0.5
C NOV 0
D NOV 1
A DEC 1
B DEC 0
C DEC 0
D DEC 1


I have some simple code for set ranges but ideally want to be able to
run one macro for differening number rows and columns.
Any help appreciated.
 
Try this code. It is generic. you should be able to modify as needed.


Sub main()
Dim Table As Range
Dim DestinationLoc As Range

With Sheets("Sheet1")
Set StartCell = .Range("A1")
LastCol = StartCell.End(xlToRight).Column
LastRow = StartCell.End(xlDown).Row
Set Table = .Range(StartCell, .Cells(LastRow, LastCol))
End With
Set DestinationLoc = Sheets("Sheet2").Range("A1")
Call MakeRows(Table, DestinationLoc)

End Sub
Sub MakeRows(Target As Range, Destination As Range)

NumCols = Target.Columns.Count
NumRows = Target.Rows.Count
NewRowOffset = 0
'Skip header row
For RowOffset = 2 To NumRows
'skip header column
For ColOffset = 2 To NumCols
Destination.Offset(NewRowOffset, 0) = Target(RowOffset, 1).Value
Destination.Offset(NewRowOffset, 1) = Target(1, ColOffset).Value
Destination.Offset(NewRowOffset, 2) = Target(RowOffset, ColOffset)
NewRowOffset = NewRowOffset + 1
Next ColOffset
Next RowOffset
End Sub
 
Try this code.  It is generic.  you should be able to modify as needed.

Sub main()
Dim Table As Range
Dim DestinationLoc As Range

With Sheets("Sheet1")
   Set StartCell = .Range("A1")
   LastCol = StartCell.End(xlToRight).Column
   LastRow = StartCell.End(xlDown).Row
   Set Table = .Range(StartCell, .Cells(LastRow, LastCol))
End With
Set DestinationLoc = Sheets("Sheet2").Range("A1")
Call MakeRows(Table, DestinationLoc)

End Sub
Sub MakeRows(Target As Range, Destination As Range)

NumCols = Target.Columns.Count
NumRows = Target.Rows.Count
NewRowOffset = 0
'Skip header row
For RowOffset = 2 To NumRows
   'skip header column
   For ColOffset = 2 To NumCols
      Destination.Offset(NewRowOffset, 0) = Target(RowOffset, 1).Value
      Destination.Offset(NewRowOffset, 1) = Target(1, ColOffset).Value
      Destination.Offset(NewRowOffset, 2) = Target(RowOffset, ColOffset)
      NewRowOffset = NewRowOffset + 1
   Next ColOffset
Next RowOffset
End Sub










- Show quoted text -
Click to expand...

Excellent, very clever thanks
 
Back
Top