vbscript to move data to new worksheet

[KerryT]

Hi

I want to transform some data into a table on a new sheet but to me it seems complicated so I am not sure if it is possible. Below is the source data format

01/01/2014

01/02/2014

01/03/2014

01/04/2014

01/05/2014

01/06/2014

01/07/2014

01/08/2014

01/09/2014

01/10/2014

01/11/2014

01/12/2014

Column A

Column B

Column C

Column D

Jan-14

Feb-14

Mar-14

Apr-14

May-14

Jun-14

Jul-14

Aug-14

Sep-14

Oct-14

Nov-14

Dec-14

Customer A

50%

DM

£1,000

£1,000

£1,000

Customer B

150%

DM

£1,000

£1,000

£1,000

£1,000

£1,000

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col span="2"></colgroup><tbody>
</tbody>

I want the script to work down column A and for every entry go along the row and transform the data into the following format.

Column A	Column B	Column C	Column D	Value	Date
Customer A	50%		DM	£1,000	01/01/2014
Customer A	50%		DM	£1,000	01/02/2014
Customer A	50%		DM	£1,000	01/03/2014
Customer B	150%		DM	£1,000	01/03/2014
Customer B	150%		DM	£1,000	01/04/2014
Customer B	150%		DM	£1,000	01/05/2014
Customer B	150%		DM	£1,000	01/06/2014
Customer B	150%		DM	£1,000	01/07/2014

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

The number of rows in the new column should = the number of values there are against Dates. The first 4 columns are copied across and then repeated for each date that has a value. For each customer there can be up to 12 rows for the 12 months of the year.

Can anyone help, thanks.

Kerry

 

[Alan_P]

Hi Kerry,

Give this code a go....

you'll need to create a new sheet called "Transformed" (can be renamed later)

Assuming the first customer name is in Cell A3, Dates are across row 1 starting at column E... this should work;

Sub Transformed()


Dim UsdCols As Long
Dim UsdRws As Long
Dim i As Long
Dim n As Long




UsdCols = Cells(1, Columns.Count).End(xlToLeft).Column
UsdRws = Range("A" & Rows.Count).End(xlUp).Row


    For i = 3 To UsdRws
    
        For n = 5 To UsdCols
        
            If Cells(i, n).Value <> "" Then
            Range("a" & i, "d" & i).Copy Sheets("Transformed").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Cells(i, n).Copy Sheets("Transformed").Range("E" & Rows.Count).End(xlUp).Offset(1)
            Cells(1, n).Copy Sheets("Transformed").Range("F" & Rows.Count).End(xlUp).Offset(1)
            End If
            
        Next n
        
    Next i
    
Sheets("Transformed").Activate


End Sub

Cheers,
Alan.

 

[KerryT]

Hi Alan

Thanks, I initially had a subscript out of range error which I managed to resolve myself by calling a worksheet Transformed.

I have run it and I get the information in the correct columns which is brilliant so thank you. It also proves that it can be done. Ultimately I need this to run on a much larger spreadsheet and operate on sets of cells. It also ideally needs the column headings.

The set of columns will always be the same as there is one for each month. The set of rows will vary as the number of customers changes week by week.

Is there any simple way of specifying the cells that it operates on? If I need it to work on multiple sections can you repeat the loop and how would it know to pend to end of the list on the transform sheet.

I have this and few other things that I need help with so I am interested to understand if you can help.

Thanks