Fairly complex VBA Code challenge?

[zico2000]

Hey guys,

I normally would find my own answers by searching the forums and looking at similar questions in the past. However this is a tricky one and I do not really know where to start. I would dearly appreciate any help with my query? ....

I have a spreadsheet, simplified for purposes of demonstrating the problem:

Type	Store	Value	France	Germany
Colour	UK	Red	Rouge	Rot
Shape	UK	Round	Ronde	Rund
Colour	UK	Green	Verte	Grun

<tbody>
</tbody>

I am trying to write some VBA code into a Macro that I can run to produce this outcome:

Type	Store	Value
Colour	UK	Red
	FR	Rouge
	DE	Rot
Shape	UK	Round
	FR	Ronde
	DE	Rund
Colour	UK	Green
	FR	Verte
	DE	Grun

<tbody>
</tbody>

So basically it loops through each row, inserts two rows underneath and then copies France into the first added row and Germany into the second.

I hope that makes sense and I am more than happy to provide any further clarification. Many thanks in advance.

Yours hopefully,
Paul

 

[mole999]

if you changed value to UK, i would think it would model in a pivot table

 

[zico2000]

if you changed value to UK, i would think it would model in a pivot table

Hi - sorry I don't understand your answer?

I'm looking for VBA code to use in a Macro - not a pivot table.

Many thanks.

 

[Dr. Demento]

What you're trying to do is called unpivoting data (or flattening the data). A pivot table is Excel's name for a summary table (like your starting data). When you unpivot, you get a database table (what you desire, except there will be no blanks in your Type column).

John Walkenbach (Excel Tips From John Walkenbach: Creating A Database Table From A Summary Table) and DataPig Technologies (http://datapigtechnologies.com/blog...th-a-pivottable/comment-page-1/#comment-25920) both provide the same method of using an Excel wizard to muscle thru to the solution (provided the data is set up correctly).

If you're looking for a VBA solution, Michiel van der Blonk (https://michiel.wordpress.com/2009/03/12/convert-excel-tables-to-lists/), snb's approach (unpivot – Daily Dose of Excel), or Doug Glancy's work (http://yoursumbuddy.com/data-normalizer/) are good solutions. However, they require a very good understanding of code to alter to your specific situation.

An intermediate solution is from Jon Acampora (https://www.excelcampus.com/modeling/structure-pivot-table-source-data/) that he has graciously supplied a workbook that you can input your data (it will require some alteration depending on the number of rows/columns and the location of your data).

hth

Edit: apologies for the full hyperlinks; stupid work computer won't pull up the Insert Hyperlink tool.

 

[zico2000]

What you're trying to do is called unpivoting data (or flattening the data). A pivot table is Excel's name for a summary table (like your starting data). When you unpivot, you get a database table (what you desire, except there will be no blanks in your Type column).

John Walkenbach (Excel Tips From John Walkenbach: Creating A Database Table From A Summary Table) and DataPig Technologies (http://datapigtechnologies.com/blog...th-a-pivottable/comment-page-1/#comment-25920) both provide the same method of using an Excel wizard to muscle thru to the solution (provided the data is set up correctly).

If you're looking for a VBA solution, Michiel van der Blonk (https://michiel.wordpress.com/2009/03/12/convert-excel-tables-to-lists/), snb's approach (unpivot – Daily Dose of Excel), or Doug Glancy's work (http://yoursumbuddy.com/data-normalizer/) are good solutions. However, they require a very good understanding of code to alter to your specific situation.

An intermediate solution is from Jon Acampora (https://www.excelcampus.com/modeling/structure-pivot-table-source-data/) that he has graciously supplied a workbook that you can input your data (it will require some alteration depending on the number of rows/columns and the location of your data).

hth

Edit: apologies for the full hyperlinks; stupid work computer won't pull up the Insert Hyperlink tool.

Thank you for taking time to provide all these reference links.

I think I am at fault here for simplyfying the problem by presenting a simple file structure to demonstrate what I am trying to achieve.

In reality I have a spreadsheet with 100+ columns

The last few columns of each row need to be moved onto new rows in a specific column.

I don't think pivot tables is the solution. I am looking for a Loop routine that takes each row 1 at a time, creates blank rows underneath and then moves the data from the end of the row to the blank rows underneath.

It then loops onto the next row until it gets to the end.

Hope that makes sense?

I have no coding experience to the links your provided are a bit advanced for me. I was hoping someone may be able to suggest some code that would run in a macro?

Many thanks.

 

[MickG]

Try this for results on sheet2:-
NB:- To get the Country abbreviations in the results you will need to change the Headers (E & D) in The Data sheet.

[COLOR="Navy"]Sub[/COLOR] MG23Feb49
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * 3, 1 To 3)
 nray(1, 1) = "Type": nray(1, 2) = "Store": nray(1, 3) = "Value"
 c = 1
 [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    c = c + 1
    nray(c, 1) = Ray(n, 1): nray(c, 2) = Ray(n, 2): nray(c, 3) = Ray(n, 3)
    [COLOR="Navy"]For[/COLOR] ac = 4 To UBound(Ray, 2)
        c = c + 1
        nray(c, 2) = Ray(1, ac)
        nray(c, 3) = Ray(n, ac)
    [COLOR="Navy"]Next[/COLOR] ac
 [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[zico2000]

Try this for results on sheet2:-
NB:- To get the Country abbreviations in the results you will need to change the Headers (E & D) in The Data sheet.

[COLOR=Navy]Sub[/COLOR] MG23Feb49
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * 3, 1 To 3)
 nray(1, 1) = "Type": nray(1, 2) = "Store": nray(1, 3) = "Value"
 c = 1
 [COLOR=Navy]For[/COLOR] n = 2 To UBound(Ray, 1)
    c = c + 1
    nray(c, 1) = Ray(n, 1): nray(c, 2) = Ray(n, 2): nray(c, 3) = Ray(n, 3)
    [COLOR=Navy]For[/COLOR] ac = 4 To UBound(Ray, 2)
        c = c + 1
        nray(c, 2) = Ray(1, ac)
        nray(c, 3) = Ray(n, ac)
    [COLOR=Navy]Next[/COLOR] ac
 [COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Thanks Mick.

I renamed the column headers as suggested and ran the macro but it bugged out at this line: With Sheets("Sheet2").Range("A1").Resize(c, 3)

Any ideas?

 

[zico2000]

I'm such a clutz - now realise I needed to create Sheet 2 for it to work - and it works like a dream!

Thank you so much Mick You've saved my day All the best!

 

[hiker95]

zico2000,

Here is another macro for you to consider, that is based on your flat text displays, that uses two arrays in memory, and, should be fast.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C	D	E	F	G	H	I	J
1	Type	Store	Value	France	Germany
2	Colour	UK	Red	Rouge	Rot
3	Shape	UK	Round	Ronde	Rund
4	Colour	UK	Green	Verte	Grun
5
6
7
8
9
10
11
Sheet1

And, after the macro in the same worksheet, beginning in the third column to the right of the last used column of the raw data:

Excel 2007
	A	B	C	D	E	F	G	H	I	J
1	Type	Store	Value	France	Germany			Type	Store	Value
2	Colour	UK	Red	Rouge	Rot			Colour	UK	Red
3	Shape	UK	Round	Ronde	Rund				FR	Rouge
4	Colour	UK	Green	Verte	Grun				DE	Rot
5								Shape	UK	Round
6									FR	Ronde
7									DE	Rund
8								Colour	UK	Green
9									FR	Verte
10									DE	Grun
11
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub RearrangeData()
' hiker95, 02/23/2017, ME992758
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long
With ActiveSheet
  a = .Cells(1, 1).CurrentRegion
  ReDim o(1 To (UBound(a, 1) - 1) * (UBound(a, 2) - 2), 1 To 3)
  For i = 2 To UBound(a, 1)
    For c = 3 To UBound(a, 2)
      If c = 3 Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, 2)
        o(j, 3) = a(i, c)
      ElseIf a(1, c) = "France" Then
        j = j + 1: o(j, 2) = "FR": o(j, 3) = a(i, c)
      ElseIf a(1, c) = "Germany" Then
        j = j + 1: o(j, 2) = "DE": o(j, 3) = a(i, c)
      End If
    Next c
  Next i
  .Columns(UBound(a, 2) + 3).Resize(, 3).ClearContents
  With .Cells(1, UBound(a, 2) + 3).Resize(, 3)
    .Value = Array("Type", "Store", "Value")
    .Font.Bold = True
  End With
  .Cells(2, UBound(a, 2) + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(UBound(a, 2) + 3).Resize(, 3).AutoFit
End With
End Sub

Then run the RearrangeData macro.

 

[MickG]

You're welcome