Copy horizontal data vertically

[swapnilk]

Hi,

I have excel data as under, is it possible to copy horizontal data vertically as shown below?

	A	B	C	D	E	F	G
1	EmpID	123
2	1111	2222	3333		3333	2222	1111
3	5555	6666	4444		2222	7777	1111
4	4444	9999	8888		555	56	468
5	EmpID	124
6	111	223	125		45452	45454	454
7	1234	5684	5689		5354	697	359
8	EmpID	125
9	1246	2685	6564		4789	665	567
10

<tbody>
</tbody>

Result	A	B	C	D	E
1	EmpID	123
2	1111	2222	3333
3	5555	6666	4444
4	4444	9999	8888
5
6	3333	2222	1111
7	2222	7777	1111
8	555	56	468
9	EmpID	124
10	111	223	125
11	1234	5684	5689
12
13	45452	45454	454
14	5354	697	359

<tbody>
</tbody>

and so on....

The data beyond column D for that particular EmpID gets copied just above the next EmplID.

Is it even possible to do this?

 

[hiker95]

swapnilk,

Here is a macro solution for you to consider, that is based on your two flat text displays.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C	D	E	F	G	H
1	EmpID	123
2	1111	2222	3333		3333	2222	1111
3	5555	6666	4444		2222	7777	1111
4	4444	9999	8888		555	56	468
5	EmpID	124
6	111	223	125		45452	45454	454
7	1234	5684	5689		5354	697	359
8	EmpID	125
9	1246	2685	6564		4789	665	567
10
11
12
13
14
15
16
17
18
19
Sheet1

And, after the macro:

Excel 2007
	A	B	C	D	E	F	G	H
1	EmpID	123
2	1111	2222	3333
3	5555	6666	4444
4	4444	9999	8888
5
6	3333	2222	1111
7	2222	7777	1111
8	555	56	468
9	EmpID	124
10	111	223	125
11	1234	5684	5689
12
13	45452	45454	454
14	5354	697	359
15	EmpID	125
16	1246	2685	6564
17
18	4789	665	567
19
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).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorganizeData()
' hiker95, 02/03/2017, ME989196
Dim wa As Worksheet, Area As Range, sr As Long, er As Long, nr As Long, lr As Long, n As Long
Application.ScreenUpdating = False
Set wa = ActiveSheet
With wa
  lr = .Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
  For Each Area In .Range("E2:G" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      n = .Rows.Count
      If sr = er And er = lr And n = 1 Then
        nr = lr + 2
        Range("A" & nr).Resize(, 3).Value = Range("E" & sr & ":G" & er).Value
        Range("E" & sr & ":G" & er).ClearContents
      Else
        wa.Rows(er + 1).Resize(n + 1).Insert
        Range("A" & er + 2).Resize(.Rows.Count, 3).Value = Range("E" & sr & ":G" & er).Value
        Range("E" & sr & ":G" & er).ClearContents
      End If
    End With
    lr = lr + n + 1
  Next Area
  .Columns(1).Resize(, 3).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorganizeData macro.

 

[hiker95]

swapnilk,

Sorry, be back in a little while.

 

[hiker95]

swapnilk,

Here is a new macro solution (that is shorter) for you to consider, that is based on your two flat text displays.

With the same screenshots, and, instructions as my last reply #2.

Sub ReorganizeData_V2()
' hiker95, 02/04/2017, ME989196
Dim wa As Worksheet, Area As Range, sr As Long, er As Long, lr As Long, n As Long
Application.ScreenUpdating = False
Set wa = ActiveSheet
With wa
  lr = .Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
  For Each Area In .Range("E1:G" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      n = .Rows.Count
      wa.Rows(er + 1).Resize(n + 1).Insert
      Range("A" & er + 2).Resize(.Rows.Count, 3).Value = Range("E" & sr & ":G" & er).Value
      Range("E" & sr & ":G" & er).ClearContents
    End With
  Next Area
  .Columns(1).Resize(, 3).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Then run the ReorganizeData_V2 macro.

 

[Peter_SSs]

Assuming layout per post #2 and nothing in columns H:K, this variation might also do what you want.

Sub Rearrange()
  Dim rA As Range
  
  Application.ScreenUpdating = False
  For Each rA In Columns("E:G").SpecialCells(xlConstants).Areas
    With rA
      .Offset(-1).Resize(.Rows.Count + 1, 7).Cut
      .Offset(.Rows.Count, -4).Insert Shift:=xlDown
    End With
  Next rA
  Application.ScreenUpdating = True
End Sub