iterative macro to create rows and populate with copied data 3

[Breskin]

The procedure I need to implement in Excel inserts 3 new rows below two existing rows in a spreadsheet, and then copies data from the row above those new rows into each of the new rows, and then moves down to the next "old row" inserts 3 new rows, and copies the second old row into these rows. For the next thousand (or more) old rows.

Interpolated values in the new rows (based on the values in the old rows above and below them) would be nice, but that is not essential. What is essential is to automate insertion of the rows containing the in-between values without harming the old values.

The purpose is to allow correction of depth recorded by a submerged instrument that creates a record every 15 minutes, using atmospheric pressure from a buoy that creates a record every hour.

In the macro recorder I first insert new rows

Rows("3:5&quot.Select
Selection.Insert Shift:=xlDown
Rows("7:9&quot.Select
Selection.Insert Shift:=xlDown
etc.

and then I copy the existing row into new rows

Rows("2:2&quot.Select
Application.CutCopyMode = False
Selection.Copy
Rows("2:5&quot.Select
ActiveSheet.Paste
Rows("6:6&quot.Select
Application.CutCopyMode = False
Selection.Copy
Rows("6:9&quot.Select
etc.

This works fine for a small worksheet, but is unscalable for a big one. How can I automate this process?

 

[dsi]

This will make 3 copies of each row of data, starting with row 2. You can put this code in the object window for the worksheet. You can also put it in a separate module. Then, the code will work on the active worksheet.

Sub ExpandData()
    Dim iRow As Long
    Dim s1 As String
    Dim s2 As String
    iRow = 2    'First Row of Data
    Do While Len(Range("A" & iRow)) > 0
        s1 = CStr(iRow + 1) & ":" & CStr(iRow + 3)
        Rows(s1).Insert Shift:=xlDown
        s2 = CStr(iRow) & ":" & CStr(iRow)
        Rows(s2).Copy Rows(s1)
        iRow = iRow + 4
    Loop
    MsgBox "Done!"
End Sub

Hope this helps... DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[Breskin]

Based on a suggestion from ivymike that reads

Sub Example1()
'example 1
' select every-other row from 1 to 11, one at a time
' turn them yellow to leave evidence

'define variable x as integer
Dim x As Integer

'begin a loop, starting with 1 and
'ending with 11, increment x by 2
For x = 1 To 11 Step 2

'select row number x
Rows(x).Select

'fill it with solid light yellow
With Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
End With

'continue looping with next value
Next x
End Sub

I struggled for a while and finally took this path:

Sub fabricate_data()

' select every-fourth row from 1 to 4400,
' Create a row below and copy data into it
' Create a row below and copy data into it
' Create a row below and copy data into it
'define variable x as integer
Dim x As Integer

'begin a loop, starting with 1 and
'ending with 4400, increment x by 4
For x = 1 To 4400 Step 4

'select row number x
Rows(x).Select

'create and fill new row with data in row above
'create and fill new row with data in row above
'create and fill new row with data in row above

With Selection
Application.CutCopyMode = False
Selection.Copy
.EntireRow.Insert
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
.EntireRow.Insert
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
.EntireRow.Insert
ActiveSheet.Paste

End With

'continue looping with next value
Next x
End Sub

Now ... the next challenge - how to embed a loop inside one or the other of these solutions that will create interpolated data based on the values in some but not all of those original rows?

And THANKS. I've been a spreadsheet person for decades and never actually automated anything before. This has been like turning on the lights.