Re-organize data from a 2 dimensional grid to a single dimensional grid - see example below

[amols.jadhav]

Hi Experts,

I am new to this forum, I need help for following query

Re-organize data from a 2 dimensional grid to a single dimensional grid - see example below

source data:
Item Sales MH, GJ, KA
A 1 2 3
B 4 5 6
C 7 8 9


reformat to the following
Item STATE Sales
A MH 1
B MH 4
C MH 7
A GJ 2
B GJ 5
C GJ 8
A KA 3
B KA 6
C KA 9

Thanks,

Amol J

 

[amols.jadhav]

Anybody know how to do it then please reply

Hi Experts,

I am new to this forum, I need help for following query

Re-organize data from a 2 dimensional grid to a single dimensional grid - see example below

source data:
Item Sales MH, GJ, KA
A 1 2 3
B 4 5 6
C 7 8 9


reformat to the following
Item STATE Sales
A MH 1
B MH 4
C MH 7
A GJ 2
B GJ 5
C GJ 8
A KA 3
B KA 6
C KA 9

Thanks,

Amol J

 

[Mike7952]

Give this a try

Sub abc()
 Dim iCol As Long, LastCol As Long
 Dim irow As Long, LastRow As Long, n As Long
 Dim a() As Variant
 
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
 
 ReDim a(1 To (LastRow - 1) * (LastCol - 1), 1 To LastCol - 1)
 
 n = 1
 For iCol = 2 To LastCol
    For irow = 2 To LastRow
        a(n, 1) = Cells(irow, 1)
        a(n, 2) = Cells(1, iCol)
        a(n, 3) = Cells(irow, iCol)
        n = n + 1
    Next
 Next
 Worksheets("Sheet2").Range("a1").Resize(UBound(a), UBound(a, 2)) = a
End Sub

 

[iyyi]

If you want to place the output in different location you can use this

Sub ReOrg()
Dim r As Long, Lc As Long, Lr As Long
Const c As Integer = 6 ' The first new column
r = 2 'The first new row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
Lr = Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To Lc
    For i = 2 To Lr
        Cells(r, c + 1) = Cells(1, j)
        Cells(r, c) = Cells(i, 1)
        Cells(r, c + 2) = Cells(i, j)
        r = r + 1
    Next i
Next j
End Sub

 

[amols.jadhav]

Thanks a lot that's what I was looking for.


Regards,

Amol

If you want to place the output in different location you can use this

Sub ReOrg()
Dim r As Long, Lc As Long, Lr As Long
Const c As Integer = 6 ' The first new column
r = 2 'The first new row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
Lr = Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To Lc
    For i = 2 To Lr
        Cells(r, c + 1) = Cells(1, j)
        Cells(r, c) = Cells(i, 1)
        Cells(r, c + 2) = Cells(i, j)
        r = r + 1
    Next i
Next j
End Sub