Conditional cut and paste row range by quantity of columns

anmedia

New Member
Joined
Oct 19, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

smozgur

BatCoder
Joined
Feb 28, 2002
Messages
1,281
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
ABCDEFGHIJKLMNOPQRSTU
1a1
2b12
3c1
4d1234567891011121314151617181920
5e12345678910
6f12
Sheet1

This is the VBA code:
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
ABCDEFGHI
1a1
2b12
3c1
4d12345678
5d910111213141516
6d17181920
7e12345678
8e910
9f12
Sheet1

Note: It overwrites the original range.
 

anmedia

New Member
Joined
Oct 19, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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
ABCDEFGHIJKLMNOPQRSTU
1a1
2b12
3c1
4d1234567891011121314151617181920
5e12345678910
6f12
Sheet1

This is the VBA code:
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
ABCDEFGHI
1a1
2b12
3c1
4d12345678
5d910111213141516
6d17181920
7e12345678
8e910
9f12
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,011
Messages
5,599,331
Members
414,305
Latest member
scarletX

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top