Transform table data using excel VBA

Question

I would like to easily transform table data to a different table format without using any pivot table. I would like to do this with excel VBA, so with the press of a button I could get the desired result, but I don't know enough how to code this. Any help is appreciated.

Column E to Q contains the sizes (36 untill 48)

Please see screenshot below which shows example of input data and output table below:

I have this code, but it doesn't quite do yet what I want:

Sub TESTexample()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim r As Integer
Dim c As Integer
For r = lastrow To 2 Step -1
For c = lastcol To 3 Step -1If Cells(r, c) <> "" Then
Rows(r + 1).Insert
Cells(r + 1, 1) = Cells(r, 1)
Cells(r + 1, 2) = Cells(r, c)
Cells(r, c).Clear
Else: Rows(r).Delete
End If
Next
Next
End Sub

EDIT: I found the solution, following code works:

Sub Button1_Click()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column

Dim r As Integer
Dim c As Integer

For r = lastrow To 2 Step -1

    For c = lastcol To 7 Step -1
        If Cells(r, c) <> "" Then
            Rows(r + 5).Insert
            Cells(r + 5, 1) = Cells(1, c)
            Cells(r + 5, 2) = Cells(r, 1)
            Cells(r + 5, 3) = Cells(r, 2)
            Cells(r + 5, 4) = Cells(r, 3)
            Cells(r + 5, 5) = Cells(r, 5)
            Cells(r + 5, 6) = Cells(r, c)

            Cells(r, c).Clear
        'Else: Rows(r).Delete
        End If
    Next

Next
End Sub

Kind regards, PJ

Welcome to Stack Overflow. Please note that because this is no free code writing service it is necessary to show either what you have tried so far and where you got stuck or errors (by showing your code) or at least to show what you have researched and the effort you made. Otherwise it is just asking us to do all the work for you. Reading [ask] might help you to improve your question. — Pᴇʜ, Feb 18 '19 at 10:56
How much do you know? Can you make a stab? In essence it's just a loop and you check if there is a number in E:Q and then copy some cells across. — SJR, Feb 18 '19 at 11:10
I updated my question with a code example, but it does not give the required output yet. — Pieterjanvl, Feb 18 '19 at 11:28
I would like the layout of the input table to be translated to the output table. — Pieterjanvl, Feb 18 '19 at 11:39
Yes I know. What I'm asking is: does your input table always have the same layout? is it always columns A-R, are the columns always in the same order? And if not, what is the logic. — SJR, Feb 18 '19 at 11:45
Yes, input table is always of that same format. Columns A-R. — Pieterjanvl, Feb 18 '19 at 11:49
@Pieterjanvl Please note that row counting variables need to be of type `Long` because Excel has more rows than `Integer` can handle: `Dim lastrow As Long`. I recommend [always to use Long instead of Integer](https://stackoverflow.com/a/26409520/3219613) in VBA since there is no benefit in `Integer` at all. — Pᴇʜ, Feb 18 '19 at 12:48

score 0 · Answer 1 · answered Feb 18 '19 at 11:55

I think it's easier to move the table values to a new table rather than re-jig the input table, which I think is what your code was attempting.

This puts the results on Sheet2 and assumes input table on Sheet1 and your data starts at row 3 so you may need to amend all those.

Sub x()

Dim r As Long, r1 As Range, r2 As Range, ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Worksheets("Sheet1") 'input
Set ws2 = Worksheets("Sheet2") 'output

ws2.Range("A1:F1").Value = Array("Size", "Article", "Model", "Color", "Amount", "Location")

With ws1
    For r = 3 To .Range("A" & Rows.Count).End(xlUp).Row
        If .Cells(r, "D") > 0 Then 'tot
            Set r1 = Range(.Cells(r, "E"), .Cells(r, "Q")).SpecialCells(xlCellTypeConstants)
            For Each r2 In r1
                ws2.Range("A" & Rows.Count).End(xlUp)(2).Value = .Cells(2, r2.Column).Value 'size
                ws2.Range("B" & Rows.Count).End(xlUp)(2).Resize(, 3).Value = .Cells(r, 1).Resize(, 3).Value 'article/model/colour
                ws2.Range("E" & Rows.Count).End(xlUp)(2).Value = r2.Value ' amount
                ws2.Range("F" & Rows.Count).End(xlUp)(2).Value = .Cells(r, "R").Value 'location
            Next r2
        End If
    Next r
End With

End Sub

Thanks for the help :) I found the solution by trying some more. I added it to my original question. — Pieterjanvl, Feb 18 '19 at 12:25

score 0 · Answer 2 · answered Feb 18 '19 at 12:39

The following code will do what you are intending, it will loop through the range from E to Q and if the cell is not empty it will write the row details in the new table:

Sub Transform()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'get the last row and last column with data
ws.Range(ws.Cells(LastRow + 2, 1), ws.Cells(LastRow + 2, 6)).Value = Array("Size", "Article", "Model", "Color", "Amount", "Location")
'insert new headers below the table

Set Rng = ws.Range(ws.Cells(2, 5), ws.Cells(LastRow, LastCol - 1))
For Each c In Rng
    If c.Value <> "" Then
        NextRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
        ws.Cells(NextRow, 1).Value = ws.Cells(1, c.Column).Value
        ws.Cells(NextRow, 2).Value = ws.Cells(c.Row, 1).Value
        ws.Cells(NextRow, 3).Value = ws.Cells(c.Row, 2).Value
        ws.Cells(NextRow, 4).Value = ws.Cells(c.Row, 3).Value
        ws.Cells(NextRow, 5).Value = c.Value
        ws.Cells(NextRow, 6).Value = ws.Cells(c.Row, LastCol).Value
    End If
Next c
End Sub

Transform table data using excel VBA

2 Answers2