Copy every 4 cells and paste it into in the next row till there is a empty cell

[sairam89]

Hi
I am a newbie to macros and i want to use macro to copy and paste the table data

Please look into the below tables and you will have a clear picture of what kind of result i am looking for

Input

User	O	D	M	T	O	D	M	T	O	D	M	T
A	101	106	1	1	106	201	2	2	201	101	1	1
B	201	203	2	2	203	106	1	1

<colgroup><col style="width:48pt" width="64" span="13"> </colgroup><tbody>
</tbody>

Output

	O	D	M	T
A	101	106	1	1
	106	201	2	2
	201	101	1	1
B	201	203	2	2
	203	106	1	1

<colgroup><col style="width:48pt" width="64" span="5"> </colgroup><tbody>
</tbody>

Thanks in advance

 

[Peter_SSs]

Welcome to the MrExcel board!

Try this in a copy of your workbook.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, r As Long, uba2 As Long
  
  a = Range("A1").CurrentRegion.Value
  uba2 = UBound(a, 2)
  ReDim b(1 To (uba2 - 1) / 4 * (UBound(a, 1) - 1), 1 To 5)
  For i = 2 To UBound(a)
    b(r + 1, 1) = a(i, 1)
    For j = 2 To uba2 Step 4
      r = r + 1
      For k = 1 To 4
        b(r, k + 1) = a(i, j + k - 1)
      Next k
    Next j
  Next i
  With Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(, 5)
    .Value = Range("A1").Resize(, 5).Value
    .Offset(1).Resize(UBound(b)).Value = b
  End With
End Sub

My data & results:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	User	O	D	M	T	O	D	M	T	O	D	M	T
2	A	101	106	1	1	106	201	2	2	201	101	1	1
3	B	201	203	2	2	203	106	1	1
4
5	User	O	D	M	T
6	A	101	106	1	1
7		106	201	2	2
8		201	101	1	1
9	B	201	203	2	2
10		203	106	1	1
Rearrange

 

[sairam89]

it worked well
Thank you very much

 

[Peter_SSs]

it worked well
Thank you very much

You're welcome. Thanks for letting us know.

 

[sairam89]

How can I skip blank rows in this table while rearranging

Thanks in advance

 

[Peter_SSs]

How can I skip blank rows in this table while rearranging

See if this is it. (Red = deletions, blue = additions)

Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, r As Long, uba2 As Long
  
 <del> a = Range("A1").CurrentRegion.Value</del>
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To (uba2 - 1) / 4 * (UBound(a, 1) - 1), 1 To 5)
  For i = 2 To UBound(a)
    If a(i, 1) <> "" Then
      b(r + 1, 1) = a(i, 1)
      For j = 2 To uba2 Step 4
        r = r + 1
        For k = 1 To 4
          b(r, k + 1) = a(i, j + k - 1)
        Next k
      Next j
    End If
  Next i
  With Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(, 5)
    .Value = Range("A1").Resize(, 5).Value
    .Offset(1).Resize(UBound(b)).Value = b
  End With
End Sub

 

[sairam89]

Blank rows are still there problem is not resolved

Input

	O	D	M	T	O	D	M	T	O	D	M	T
S	28	30	1	2	30	28	1	2	30	28	1	2
B	28	30	1	2
C	28	30	1	2	30	28	1	2	30	28	1	2
V	28	30	1	2	30	28	1	2
D	28	30	1	2	30	28	1	2	30	28	1	2

<colgroup><col width="64" span="13" style="width:48pt"> </colgroup><tbody>
</tbody>

Output

O D M T S 28 30 1 2 30 28 1 2 30 28 1 2 B 28 30 1 2 C 28 30 1 2 30 28 1 2 30 28 1 2 V 28 30 1 2 30 28 1 2 D 28 30 1 2 30 28 1 2 30 28 1 2 <colgroup><col width="64" span="5" style="width:48pt"> </colgroup><tbody> </tbody>

<colgroup><col width="64" span="5" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[Peter_SSs]

Blank rows are still there problem is not resolved

Sorry, you didn't previously specify which table to skip blank rows in and I guessed the original table, not the result table.

Try this (which should skip blanks in either table based on your sample data)

Sub Rearrange_v3()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, r As Long, uba2 As Long
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To (uba2 - 1) / 4 * (UBound(a, 1) - 1), 1 To 5)
  For i = 2 To UBound(a)
    If a(i, 1) <> "" Then
      b(r + 1, 1) = a(i, 1)
      For j = 2 To uba2 Step 4
        If a(i, j) = "" Then Exit For
        r = r + 1
        For k = 1 To 4
          b(r, k + 1) = a(i, j + k - 1)
        Next k
      Next j
    End If
  Next i
  With Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(, 5)
    .Value = Range("A1").Resize(, 5).Value
    .Offset(1).Resize(UBound(b)).Value = b
  End With
End Sub