Automate duplicating a row and moving data, if data exists in a cell

D

dougbohr

New Member
Joined
Jun 4, 2020
Messages
6
Office Version
  1. 2013
Platform
  1. Windows
I am trying to automate this process, as I have hundreds of rows to go through. Any help is greatly appreciated!

We are moving company contacts from Outlook and into another program. When I export contacts from Outlook to a .csv file, each company's information is contained in a single row.

Some companies only have (1) email address, while other companies have (3) email addresses. They are listed under the "E-Mail Address", "E-Mail 2 Address" and "E-mail 3 Address" columns.

Here is what I would like to automate:
1) If there is an email address in the "E-Mail 2 Address" column, a new row needs to be added below the existing row, and the email address from "E-Mail 2 Address" needs to go in the "E-Mail Address" column in the new row. Then, all other information needs to be duplicated in the newly created row (Company Name, Street, City, State, Zip, Phone, etc. is all duplicated in the new row, matching the row above it).

2) If there is an email address in the "E-Mail 2 Address" AND the "E-Mail 3 Address" columns, it is the same process as above, but (2) new rows need to be created: (1 for each of the emails). All of the other columns (Company Name, Street, City, State, Zip, Phone, etc. is all duplicated, so there will be (3) rows with the same information).

Example:
(all information below is dummy)

This needs to become (see below)
CompanyStreetCityStateZip CodeBusiness PhoneE-Mail AddressEmail 2 AddressEmail 3 Address
Rack Systems55 Stadium RoadHinckleyCO56258(785) 555-6696estimating@racksys.com
Bob's Painting4527 Long AvenueBoulderCO42685(859) 555-6895bob@painting.comsteve@painting.commark@painting.com
Frank's Welding699 59th StreetVailIL42845(989) 555-8458fwash@fweld.comblong@fweld.com
United Structural Steel Co.PO Box 5874RockfordCO42698(458) 555-1245carl@ussteel.com
Anytime Roofing Inc.9885 State StreetLittletownCO42574(778) 555-6985w_shram@anytimeroof.comb_bender@anytimeroof.comc_carlson@anytimeroof.com

Final Result:
CompanyStreetCityStateZip CodeBusiness PhoneE-Mail AddressEmail 2 AddressEmail 3 Address
Rack Systems55 Stadium RoadHinckleyCO56258(785) 555-6696estimating@racksys.com
Bob's Painting4527 Long AvenueBoulderCO42685(859) 555-6895bob@painting.com
Bob's Painting4527 Long AvenueBoulderCO42685(859) 555-6895steve@painting.com
Bob's Painting4527 Long AvenueBoulderCO42685(859) 555-6895mark@painting.com
Frank's Welding699 59th StreetVailIL42845(989) 555-8458fwash@fweld.com
Frank's Welding699 59th StreetVailIL42845(989) 555-8458blong@fweld.com
United Structural Steel Co.PO Box 5874RockfordCO42698(458) 555-1245carl@ussteel.com
Anytime Roofing Inc.9885 State StreetLittletownCO42574(778) 555-6985w_shram@anytimeroof.com
Anytime Roofing Inc.9885 State StreetLittletownCO42574(778) 555-6985b_bender@anytimeroof.com
Anytime Roofing Inc.9885 State StreetLittletownCO42574(778) 555-6985c_carlson@anytimeroof.com


Thanks,
Doug
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
How about
VBA Code: 
Sub dougbohr()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   Ary = Sheets("Main").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 7)
   For r = 2 To UBound(Ary)
      For c = 7 To UBound(Ary, 2)
         If Ary(r, c) = "" Then Exit For
         nr = nr + 1
         For nc = 1 To 6
            Nary(nr, nc) = Ary(r, nc)
         Next nc
         Nary(nr, 7) = Ary(r, c)
      Next c
   Next r
   With Sheets("Main")
      .Range("A1").CurrentRegion.Offset(1).Value = ""
      .Range("A2").Resize(nr, 7).Value = Nary
   End With
End Sub
Change sheet name to suit.
 
Upvote 0
Thanks!! It works perfectly for the sample.

I provided a simplified example, hoping that I could adjust once I knew the solution. I thought I would be entering a formatting formula... (e.g. - If information is contained in column "H" or "I", create a new row and put it in column "G"). Unfortunately, I do not know Visual Basic at all.

In your solution, if there is information in column H (8th column from left) or any columns to the right of that (to infinity?)... it duplicates the row and puts the email address in column G (7th column from left). I see that you are specifying columns in the code... 1 To 7... etc. I see that you're referring to r = 2, c = 7, which I assume is 2nd row, 7th column? I played around with it to see how changing the numbers affected things, but I just don't know how to do it. :(


If you have time, please see the following:
(all information below is dummy).
This is the exact format of the file I am using.

This needs to become (see below)

First NameLast NameEmail AddressE-mail 2 AddressE-mail 3 AddressCompanyStreetCityStateZip CodeCountryBusiness PhoneCost CodePermission TemplateWebpage
estimating@racksys.comRack Systems55 Stadium RoadHinckleyCO
56258​
United States of America(785) 555-669610500externalwww.rack.com
bob@painting.comsteve@painting.commark@painting.comBob's Painting4527 Long AvenueBoulderCO
42685​
United States of America(859) 555-689515500externalwww.bobpainting.com
fwash@fweld.comblong@fweld.comFrank's Welding699 59th StreetVailIL
42845​
United States of America(989) 555-845802525 | 02900 | 03300 | 16100externalwww.frank.com
carl@ussteel.comUnited Structural Steel Co.PO Box 5874RockfordCO
42698​
United States of America(458) 555-124509310 | 09650 | 09680externalwww.uss.com
w_shram@anytimeroof.comb_bender@anytimeroof.comc_carlson@anytimeroof.comAnytime Roofing, Inc.9885 State StreetLittletownCO
42574​
United States of America(778) 555-698502600 | 02200externalwww.anytimeroofing.com

Final Result:

First NameLast NameEmail AddressE-mail 2 AddressE-mail 3 AddressCompanyStreetCityStateZip CodeCountryBusiness PhoneCost CodePermission TemplateWebpage
estimating@racksys.comRack Systems55 Stadium RoadHinckleyCO
56258​
United States of America(785) 555-669610500externalwww.rack.com
bob@painting.comBob's Painting4527 Long AvenueBoulderCO
42685​
United States of America(859) 555-689515500externalwww.bobpainting.com
steve@painting.comBob's Painting4527 Long AvenueBoulderCO
42685​
United States of America(859) 555-689515500externalwww.bobpainting.com
mark@painting.comBob's Painting4527 Long AvenueBoulderCO
42685​
United States of America(859) 555-689515500externalwww.bobpainting.com
fwash@fweld.comFrank's Welding699 59th StreetVailIL
42845​
United States of America(989) 555-845802525 | 02900 | 03300 | 16100externalwww.frank.com
blong@fweld.comFrank's Welding699 59th StreetVailIL
42845​
United States of America(989) 555-845802525 | 02900 | 03300 | 16100externalwww.frank.com
carl@ussteel.comUnited Structural Steel Co.PO Box 5874RockfordCO
42698​
United States of America(458) 555-124509310 | 09650 | 09680externalwww.uss.com
w_shram@anytimeroof.comAnytime Roofing, Inc.9885 State StreetLittletownCO
42574​
United States of America(778) 555-698502600 | 02200externalwww.anytimeroofing.com
b_bender@anytimeroof.comAnytime Roofing, Inc.9885 State StreetLittletownCO
42574​
United States of America(778) 555-698502600 | 02200externalwww.anytimeroofing.com
c_carlson@anytimeroof.comAnytime Roofing, Inc.9885 State StreetLittletownCO
42574​
United States of America(778) 555-698502600 | 02200externalwww.anytimeroofing.com

The logic I'm trying to automate:
If text (email address) is in the 4th or 5th column, 1) create a new row below, 2) duplicate all information in that row from the row above it, and 3) move the text (email address) from the 4th or 5th column to the 3rd column of the newly created row(s).

Hopefully I can tell from your new code how it's all working. Example: I add a "Middle Name" column between the "First" and "Last" name columns. That means that the (3) email columns (currently in the 3rd, 4th and 5th columns from the left) shift to the right by 1 column. In the example above, I will then want to take info from the 5th or 6th column (not the 4th or 5th column), and it will go in the 4th column (not the 3rd) of the newly created row...

Thanks,
Doug
 
Upvote 0
How about
VBA Code: 
Sub dougbohr()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   Ary = Sheets("Main").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To UBound(Ary, 2))
   For r = 2 To UBound(Ary)
      For c = 3 To 5
         If Ary(r, c) = "" Then Exit For
         nr = nr + 1
         Nary(nr, 1) = Ary(r, 1)
         Nary(nr, 2) = Ary(r, 2)
         Nary(nr, 3) = Ary(r, c)
         For nc = 6 To UBound(Ary, 2)
            Nary(nr, nc) = Ary(r, nc)
         Next nc
      Next c
   Next r
   With Sheets("Main")
      .Range("A1").CurrentRegion.Offset(1).Value = ""
      .Range("A2").Resize(nr, UBound(Nary, 2)).Value = Nary
   End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

Share this page

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