Conditional cut and paste row range by quantity of columns

[anmedia]

Hello, I'd like some help from you, since I'm a newbie here. What I need to achieve is: Giving a table with the first column A with a type of data and subsequent columns with data to be arranged: I'd like to cut the values in rows that exceed 8 columns and insert paste them into the below row starting in column B and also copy and insert paste the value of column A. If the original row has for example 20 columns, the macro needs to execute this action 3 times. To be graphic I'm linking here images of current scenario and the expected one after the macro run. Please let me know if you need some more clarifications on this.
Thanks in advance!
A N

Before
After

 

[smozgur]

This is the sample range (that would be great if you could use XL2BB to post the sample data next time. Easier for the helper.)

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	a	1
2	b	1	2
3	c	1
4	d	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20
5	e	1	2	3	4	5	6	7	8	9	10
6	f	1	2
Sheet1

This is the VBA code:

Sub doIt()
Dim rng As Range
Dim rw As Range
Dim howMany As Integer
    
    Set rng = Selection

    For Each rw In rng.Rows
        On Error Resume Next
        howMany = rw.Columns.Count - rw.SpecialCells(xlCellTypeBlanks).Count - 1
        If Err Then
            howMany = rng.Columns.Count
        End If
        On Error GoTo 0
        If howMany > 8 Then
            rw.Offset(1).EntireRow.Insert xlDown
            rw.Offset(1).Cells(1, 1).Value = rw.Cells(1, 1)
            With rw.Offset(, 9).Resize(, howMany - 8)
                .Copy rw.Offset(1).Cells(, 2)
                .ClearContents
            End With
            Set rng = rng.Resize(rng.Rows.Count + 1)
        End If
    Next rw
End Sub

Select the range and run the code.
This is the result:

Book1
	A	B	C	D	E	F	G	H	I
1	a	1
2	b	1	2
3	c	1
4	d	1	2	3	4	5	6	7	8
5	d	9	10	11	12	13	14	15	16
6	d	17	18	19	20
7	e	1	2	3	4	5	6	7	8
8	e	9	10
9	f	1	2
Sheet1

Note: It overwrites the original range.

 

[anmedia]

This is the sample range (that would be great if you could use XL2BB to post the sample data next time. Easier for the helper.)

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	a	1
2	b	1	2
3	c	1
4	d	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20
5	e	1	2	3	4	5	6	7	8	9	10
6	f	1	2
Sheet1

This is the VBA code:

Sub doIt()
Dim rng As Range
Dim rw As Range
Dim howMany As Integer
   
    Set rng = Selection

    For Each rw In rng.Rows
        On Error Resume Next
        howMany = rw.Columns.Count - rw.SpecialCells(xlCellTypeBlanks).Count - 1
        If Err Then
            howMany = rng.Columns.Count
        End If
        On Error GoTo 0
        If howMany > 8 Then
            rw.Offset(1).EntireRow.Insert xlDown
            rw.Offset(1).Cells(1, 1).Value = rw.Cells(1, 1)
            With rw.Offset(, 9).Resize(, howMany - 8)
                .Copy rw.Offset(1).Cells(, 2)
                .ClearContents
            End With
            Set rng = rng.Resize(rng.Rows.Count + 1)
        End If
    Next rw
End Sub

Select the range and run the code.
This is the result:

Book1
	A	B	C	D	E	F	G	H	I
1	a	1
2	b	1	2
3	c	1
4	d	1	2	3	4	5	6	7	8
5	d	9	10	11	12	13	14	15	16
6	d	17	18	19	20
7	e	1	2	3	4	5	6	7	8
8	e	9	10
9	f	1	2
Sheet1

Note: It overwrites the original range.

It worked like a charm! Thank you very much Smozgur. I've replaced selection with Range("A1").CurrentRegion to fully automate the task. Regards. AN

 

[smozgur]

It worked like a charm! Thank you very much Smozgur. I've replaced selection with Range("A1").CurrentRegion to fully automate the task. Regards. AN

Glad to hear it helps!