VBA script to insert new rows based on data in other cells... then cut data from those cells and paste into those new rows

mbnnyc

New Member
Joined
Mar 15, 2021
Messages
5
Office Version
  1. 2013
Platform
  1. Windows
Hi, I have a spreadsheet that contains mailing list data. It's in a format in which there are Alt1Email (column R), Alt2Email (column S), Alt3Email (column T), and Alt4Email (column U). Wanna cut and paste that data from those columns to the Email column (column Q) in NEW ROWs based on how many AltEmails the contact has. Then ultimately delete columns R,S,T, and U. I thought this out in a plain logic script (below) but being new to VBA I'm having trouble understand syntax a bit. Please if anyone can assist would greatly appreciate. Kind regards! Attached is the spreadsheet and screenshots.. Thanks!

----------

{If cells in columns R,S,T,U are all Populated (not null) in the row the VBA script is working on... first row being row TWO... so R2,S2,T2,U2)

then

INSERT FOUR new rows BELOW this row

AND

COPY from that "reference" row the cell values from columns A thru P... to the corresponding columns of the 4 new rows just created,

AND

CUT cell value from column R AND PASTE IT to the FIRST new row immediately under the original "reference" row into COLUMN Q

AND

CUT column S value and paste to SECOND new row's Q column

AND

CUT column T value and paste to THIRD new row's Q column

AND

CUT column U value and paste to FOURTH new row's Q column}

OR

{If out of R,S,T,U.... only columns R,S, & T (only 3 alt-emails) are populated in the current "reference" row

then

INSERT THREE new rows below this row

AND

COPY from that "reference" row the cell values from columns A thru P... and paste into to the corresponding columns of the THREE new rows just created,

AND

CUT cell value from column R AND PASTE IT to the FIRST new row immediedly under the original "reference" row

INTO COLUMN Q

AND

CUT column S value and paste to SECOND new row's Q column

AND

CUT column T value and paste to THIRD new row's Q column}

OR

{If out of R,S,T,U, only R & S (only 2 alt-emails) are populated in that "reference" row

then

INSERT TWO new rows below the reference row

AND

copy from that "reference" row the cell values from columns A thru P... and PASTE to the corresponding columns of the THREE new rows just created,

AND

CUT cell value from column R AND PASTE IT to the FIRST new row immediedly under the original "reference" row to COLUMN Q

AND

CUT column S value and Paste to SECOND new row's Q column}

OR

{If out of R,S,T, U, only column R is populated in that particular row)

then

INSERT ONE new row below the reference row

AND COPY from that "reference" row the cell values from columns A thru P... and paste into to the corresponding columns of the THREE new rows just created,




AND

CUT cell value from column R AND PASTE IT to the FIRST new row immediedly under the original "reference" row into COLUMN Q}

{If we just added 4 new rows, move down FIVE rows from the original row... if this new “reference” row is a totally blank row, END this script,

If not, make THIS row the new “reference” row AND go back to beginning of script

if we just added 3 new rows, move down FOUR rows from the original row... if this is a totally blank row, END this script

If not, make THIS row the new “reference” row AND go back to beginning of script

{if we just added 2 new rows, move down THREE rows from the original row... if this is a totally blank row, END this script,

If not, make THIS row the new “reference” row AND go back to beginning of script}

{if we just added 1 new row, move down 2 rows from the original row... if this is a totally black row, END this script, if not, make THIS row the new criteria row}

{if we added no new rows in the above process, move down to the next row below original row. if this is a totally BLANK NULL row, END this script,}

Go back to beginning criteria of this script

-------

Example:

Sheet example BEFORE running VBA script:

Add-Specific-Number-of-Rows-And-Populate-Based-On-Cell-Value.xlsx
ABCDEFGHIJKLMNOPQRSTU
1Category ACategory BCategory CCategory DCategory ECategory FCategory GCategory HCategory ICategory JFirstNameLastNamePersonalClose PersonalWhatCompanyEmailAltEmail1AltEmail2AltEmail3AltEmail4
2xxxxxxAlbertHammondxxGuitaristRolandahammond@gmail.comfenderbender@gmail.com
3xxxxCynthiaJonesPainterWarhol Inc.info@warhol.comcynthia@warhol.inccjones@gmail.com
4xDerrickLewisCarpenterAll Done Right Inc.derrick_lewis@alldoneright.org
5xEdwardAlbyxLighting DesignerBrighter Daysalbyed@brigherdays.come.alby@gmail.come.alby@mac.com
6xxxxJeffCousinsxxDancerBreakin Up Inc.jeffcousins@gmail.com
7xxMarcusKaufmanxSingerLauren Nicolemarcusk@ln.com
8xLaurenBettsDrummerFirst Instrumentslaurenbetts@hotmail.com
9xxxxPaulineHuertaxAcrobatMission Inc.aria101@aol.com
10xxxxxxxRichardGrovexBroadcasterABCc.martini@missoni.itrichard.grove@abc.comrgrove@gmail.comgrove131@hotmail.comrgrove@grove.com
Before


Sheet example AFTER running VBA script:

Add-Specific-Number-of-Rows-And-Populate-Based-On-Cell-Value.xlsx
ABCDEFGHIJKLMNOPQRSTU
1Category ACategory BCategory CCategory DCategory ECategory FCategory GCategory HCategory ICategory JFirstNameLastNamePersonalClose PersonalWhatCompanyEmailAltEmail1AltEmail2AltEmail3AltEmail4
2xxxxxxAlbertHammondxxGuitaristRolandahammond@gmail.com
3xxxxxxAlbertHammondxxGuitaristRolandfenderbender@gmail.com
4xxxxCynthiaJonesPainterWarhol Inc.info@warhol.com
5xxxxCynthiaJonesPainterWarhol Inc.cynthia@warhol.inc
6xxxxCynthiaJonesPainterWarhol Inc.cjones@gmail.com
7xDerrickLewisCarpenterAll Done Right Inc.derrick_lewis@alldoneright.org
8xEdwardAlbyxLighting DesignerBrighter Daysalbyed@brigherdays.com
9xEdwardAlbyxLighting DesignerBrighter Dayse.alby@gmail.com
10xEdwardAlbyxLighting DesignerBrighter Dayse.alby@mac.com
11xxxxJeffCousinsxxDancerBreakin Up Inc.jeffcousins@gmail.com
12xxMarcusKaufmanxSingerLauren Nicolemarcusk@ln.com
13xLaurenBettsDrummerFirst Instrumentslaurenbetts@hotmail.com
14xxxxPaulineHuertaxAcrobatMission Inc.aria101@aol.com
15xxxxxxxRichardGrovexBroadcasterABCc.martini@missoni.it
16xxxxxxxRichardGrovexBroadcasterABCrichard.grove@abc.com
17xxxxxxxRichardGrovexBroadcasterABCrgrove@gmail.com
18xxxxxxxRichardGrovexBroadcasterABCgrove131@hotmail.com
19xxxxxxxRichardGrovexBroadcasterABCrgrove@grove.com
After
 

Attachments

  • BEFORE-new-row-inserts-and-data-copys-and-cuts.png
    BEFORE-new-row-inserts-and-data-copys-and-cuts.png
    44.8 KB · Views: 10
  • AFTER-new-row-inserts-and-data-copys-and-cuts.png
    AFTER-new-row-inserts-and-data-copys-and-cuts.png
    62 KB · Views: 10

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Forgot to mention... using MS Excel 2013 for Windows and VBA 7.1 that comes with it.
 
Upvote 0
Welcome to the forum!

Try running this on a copy of the 'Before' sheet:
VBA Code:
Sub ME1165153_Split()
    Dim i As Long, j As Long, k As Long, c As Long
    Dim a, b()
    
    With ActiveSheet
        With .UsedRange.Offset(1)
            With .Resize(.Rows.Count - 1)
                a = .Value
                c = Application.CountA(.Columns(18).Resize(, 4))
                .Columns(18).Resize(, 4).ClearContents
            End With
        End With
        
        ReDim b(1 To UBound(a, 1) + c, 1 To 17)
        c = 1
        For i = 1 To UBound(a, 1)
            For j = 1 To 17
                b(c, j) = a(i, j)
            Next
            For j = 18 To UBound(a, 2)
                If a(i, j) <> "" Then
                    c = c + 1
                    For k = 1 To 16
                        b(c, k) = a(i, k)
                    Next
                    b(c, 17) = a(i, j)
                End If
            Next
            c = c + 1
        Next
        
        .Range("a2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
        .Columns.AutoFit
    End With
End Sub
 
Upvote 0
Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: multiple locations
Please provide links to all sites where you have asked this question

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.
 
Upvote 0
@mbnnyc Please post links to all sites where you have asked this question. Thanks
 
Upvote 0
@mbnnyc Please post links to all sites where you have asked this question. Thanks





 
Upvote 0

Forum statistics

Threads
1,213,556
Messages
6,114,284
Members
448,562
Latest member
Flashbond

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
Back
Top