Macro to turn a grid of data into a list of data

[tonywatsonhelp]

Hi Everyone,

I have a grid of data with names along the top and sales down the side in Sheet "Data" (see chart1)
I want to convert this data into a list in Sheet "New Data" (see chart 2)

I just can't get anything to work so please help

I figure its best if I show you an example so here is a small example of what I want:

What I have :

A

B

C

D

E

F

G

H

I

J

K

L

1

DATE

12/06/2017

SALES PERSON

Terry

Sue

Mat

Tony

Andy

John

Jo

Kevin

2

INV NO

PRODUCT

TYPE

3

1234

Glue

sticky

40

20

12

4

1235

Jam

Strawb

12

12

5

1236

Maps

Euro

60

6

1121

Glue

Dry

34

45

11

7

1000

Sand

Paper

12

8

<tbody>
</tbody>

So as you can see, I currently have all my sales in one row for each product, but I need to change this to a list like shown below.
Also its important to note that not every row has sales as Columns A, B & C are a List of Every product we Sell so some will have no sales and some clould have everyone selling as shown above.

What I want it to look like

	A	B	C	D	E	F	G
1
2	INV NO	PRODUCT	TYPE	Sales Person	Amount	Date
3	1234	Glue	sticky	Terry	40	12/06/2017
4	1234	Glue	Sticky	Tony	20	12/06/17
5	1234	Glue	Sticky	JO	12	12/06/17
6	1235	Jam	Strawb	Sue	12	12/06/17
7	1235	Jam	Strawb	Tony	12	12/06/17
8	1236	Maps	Euro	Andy	60	12/06/17
9	1121	Glue	Dry	Mat	34	12/06/17
10	1121	Glue	Dry	John	45	12/06/17
11	1121	Glue	Dry	Kevin	11	12/06/17
12	1000	Sand	Paper	Mat	12	12/06/17
8

<tbody>
</tbody>

I'm really stuck with this one so please help if you can

Thanks

Tony

 

[MickG]

Try this from sheet "Data" to sheet "New Data".

[COLOR="Navy"]Sub[/COLOR] MG06Jul23
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRay
Ray = Sheets("Data").Cells(1).CurrentRegion
c = 1
ReDim nRay(1 To 6, 1 To 1)
nRay(1, 1) = "INV NO": nRay(2, 1) = "PRODUCT": nRay(3, 1) = "TYPE"
nRay(4, 1) = "Sales Person": nRay(5, 1) = "Amount": nRay(6, 1) = "Date"
[COLOR="Navy"]For[/COLOR] n = 3 To UBound(Ray, 1)
 [COLOR="Navy"]For[/COLOR] Ac = 4 To UBound(Ray, 2)
   [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        ReDim Preserve nRay(1 To 6, 1 To c)
        nRay(1, c) = Ray(n, 1)
        nRay(2, c) = Ray(n, 2)
        nRay(3, c) = Ray(n, 3)
        nRay(4, c) = Ray(1, Ac)
        nRay(5, c) = Ray(n, Ac)
        nRay(6, c) = CDbl(DateValue(Ray(1, 2)))
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("New Data").Range("A1").Resize(c, 6)
   .Columns("F:F").NumberFormat = "dd/mm/yyyy"
   .Value = Application.Transpose(nRay)
   .Columns.AutoFit
   .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[wideboydixon]

This is based on the data you posted. Here's my Sheet:

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	DATE	12/06/2017	SALES PERSON	Terry	Sue	Mat	Tony	Andy	John	Jo	Kevin
2	INV NO	PRODUCT	TYPE
3	1234	Glue	sticky	40			20			12
4	1235	Jam	Strawb		12		12
5	1236	Maps	Euro					60
6	1121	Glue	Dry			34			45		11
7	1000	Sand	Paper			12
Sheet1

This is the code I used:

Public Sub GridToList()

Dim gridSheet As Worksheet
Dim listSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim thisCol As Long
Dim nextRow As Long

' Assume current sheet is the sheet with the grid
Set gridSheet = ActiveSheet

' Add a new sheet for the list
Set listSheet = Sheets.Add

' Set up header row on new sheet
listSheet.Cells(1, 1).Value = gridSheet.Cells(2, 1).Value
listSheet.Cells(1, 2).Value = gridSheet.Cells(2, 2).Value
listSheet.Cells(1, 3).Value = gridSheet.Cells(2, 3).Value
listSheet.Cells(1, 4).Value = gridSheet.Cells(1, 3).Value
listSheet.Cells(1, 5).Value = "AMOUNT"
listSheet.Cells(1, 6).Value = gridSheet.Cells(1, 1).Value

' Start at row 2 on new sheet
nextRow = 2

' Find last row as column on the grid sheet
With gridSheet
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
End With

' Process all rows
For thisRow = 3 To lastRow
    ' Process all columns
    For thisCol = 4 To lastCol
        ' Sale?
        If gridSheet.Cells(thisRow, thisCol).Value <> "" Then
            listSheet.Cells(nextRow, 1).Value = gridSheet.Cells(thisRow, 1).Value
            listSheet.Cells(nextRow, 2).Value = gridSheet.Cells(thisRow, 2).Value
            listSheet.Cells(nextRow, 3).Value = gridSheet.Cells(thisRow, 3).Value
            listSheet.Cells(nextRow, 4).Value = gridSheet.Cells(1, thisCol).Value
            listSheet.Cells(nextRow, 5).Value = gridSheet.Cells(thisRow, thisCol).Value
            listSheet.Cells(nextRow, 6).Value = gridSheet.Cells(1, 2).Value
            nextRow = nextRow + 1
        End If
    Next thisCol
Next thisRow

End Sub

Which gave me this:

Book1
	A	B	C	D	E	F
1	INV NO	PRODUCT	TYPE	SALES PERSON	AMOUNT	DATE
2	1234	Glue	sticky	Terry	40	12/06/2017
3	1234	Glue	sticky	Tony	20	12/06/2017
4	1234	Glue	sticky	Jo	12	12/06/2017
5	1235	Jam	Strawb	Sue	12	12/06/2017
6	1235	Jam	Strawb	Tony	12	12/06/2017
7	1236	Maps	Euro	Andy	60	12/06/2017
8	1121	Glue	Dry	Mat	34	12/06/2017
9	1121	Glue	Dry	John	45	12/06/2017
10	1121	Glue	Dry	Kevin	11	12/06/2017
11	1000	Sand	Paper	Mat	12	12/06/2017
Sheet2

WBD

 

[tonywatsonhelp]

Thanks MickG & WideBoy,
Both codes worked great so thank you,

Another problem solved

Tony

 

[hiker95]

tonywatsonhelp,

Here is another macro solution for you to consider, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns.

I assume that both worksheets exist.

Samle raw data worksheets:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L
1	DATE	12/6/2017	SALES PERSON	Terry	Sue	Mat	Tony	Andy	John	Jo	Kevin
2	INV NO	PRODUCT	TYPE
3	1234	Glue	sticky	40			20			12
4	1235	Jam	Strawb		12		12
5	1236	Maps	Euro					60
6	1121	Glue	Dry			34			45		11
7	1000	Sand	Paper			12
8
Data

Excel 2007
	A	B	C	D	E	F	G
1
2	INV NO	PRODUCT	TYPE	Sales Person	Amount	Date
3
4
5
6
7
8
9
10
11
12
13
New Data

And, after the macro:

Excel 2007
	A	B	C	D	E	F	G
1
2	INV NO	PRODUCT	TYPE	Sales Person	Amount	Date
3	1234	Glue	sticky	Terry	40	12/6/2017
4	1234	Glue	sticky	Tony	20	12/6/2017
5	1234	Glue	sticky	Jo	12	12/6/2017
6	1235	Jam	Strawb	Sue	12	12/6/2017
7	1235	Jam	Strawb	Tony	12	12/6/2017
8	1236	Maps	Euro	Andy	60	12/6/2017
9	1121	Glue	Dry	Mat	34	12/6/2017
10	1121	Glue	Dry	John	45	12/6/2017
11	1121	Glue	Dry	Kevin	11	12/6/2017
12	1000	Sand	Paper	Mat	12	12/6/2017
13
New Data

Sub ReorganizeData()
' hiker95, 07/06/2017, ME1012935
Application.ScreenUpdating = False
Dim wd As Worksheet, wnd As Worksheet
Dim a As Variant, lr As Long, lc As Long, i As Long, c As Long, n As Long
Dim o As Variant, j As Long
Set wd = Sheets("Data")
Set wnd = Sheets("New Data")
With wd
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.Count(.Range(.Cells(3, 4), .Cells(lr, lc)))
  ReDim o(1 To n, 1 To 6)
End With
For i = 3 To lr
  For c = 4 To lc
    If Not a(i, c) = vbEmpty Then
      j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, 2): o(j, 3) = a(i, 3)
      o(j, 4) = a(1, c): o(j, 5) = a(i, c): o(j, 6) = a(1, 2)
    End If
  Next c
Next i
With wnd
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  If lr > 2 Then
    .Range(.Cells(3, 1), .Cells(lr, 6)).ClearContents
  End If
  .Cells(3, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub