Macro to insert rows and autofill

anglais428

Well-known Member
Joined
Nov 23, 2009
Messages
634
Office Version
  1. 2016
Platform
  1. Windows
Hi Guys,

I'm looking to see if it is possible to create a Macro that will insert 38 rows after each cell in my list of countries, then autofill down the empty rows with the country name so that each country will go from appearing once to appearing 38 times. For example:

My initial list is say (in cells A1,A2,A3):

Argentina
Australia
UK

In the end I want it to say Argentina 38 times (from cell A1:A38), then Australia 38 times (cell A39:A77) then UK 38 times( cell A78:A116)

Is this possible?

I have this Macro to insert rows but I don't know anything about coding so cannot modify it to replicate the names

Sub AddRows()
Dim lastrow As Long, cell As Range, i As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
Set cell = Cells(i, 1)
cell.Offset(1, 0).Resize(38, 1).EntireRow.Insert
Next
End Sub

Many thanks,
 

Some videos you may like

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

nigelk

Well-known Member
Joined
Aug 30, 2008
Messages
535
Maybe something along these lines?

Code:
Sub Macro1()
Dim CRange As Range
Rows("2:38").Insert Shift:=xlDown
Set CRange = Range(Cells(2, 1), Cells(38, 1))
Range("a1").Copy Destination:=CRange
Rows("40:76").Insert Shift:=xlDown
Set CRange = Range(Cells(40, 1), Cells(76, 1))
Range("a39").Copy Destination:=CRange
Set CRange = Range(Cells(78, 1), Cells(114, 1))
Range("a77").Copy Destination:=CRange
 
End Sub
 

anglais428

Well-known Member
Joined
Nov 23, 2009
Messages
634
Office Version
  1. 2016
Platform
  1. Windows
That is good for those three locations. However I have many locations (over 400) that I would like this to run for - is there anyway the code you provided can be built into a loop or something?

Thanks,
 

nigelk

Well-known Member
Joined
Aug 30, 2008
Messages
535
Heres the best I could do, don't know how long it will take with over 400 rows though. It puts the results in Col B

Code:
Sub test()
Dim Countries As Long
Dim RowNum As Long
Dim CRange As Range
Dim X As Long
 
Countries = Sheets("sheet1").Range("A65536").End(xlUp).Row
 
For X = 1 To Countries
 
RowNum = Sheets("sheet1").Range("B65536").End(xlUp).Row
 
If X > 1 Then
RowNum = RowNum + 1
End If
 
Set CRange = Range(Cells(RowNum, 2), Cells(RowNum + 37, 2))
 
Cells(X, 1).Copy Destination:=CRange
 
Next
 
End Sub

Then you can just delete col A.
 

anglais428

Well-known Member
Joined
Nov 23, 2009
Messages
634
Office Version
  1. 2016
Platform
  1. Windows
Thanks alot NigelK, this works really well. Appreciate your help.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,307
Messages
5,600,869
Members
414,411
Latest member
Snowmanaus

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