VBA Loop

[krisbowls]

Hi I'm new to VBA and have been trying to learn looping, but with little success. I created a macro with the "Record Macro" button in Excel, but would like to create a loop instead.

Basically, the Macro I have creates two new rows below data, then two more, then two more etc. I would like to make a loop so that it does this until it encounters the last row with data.

After that, I currently have another line of code copying the data in the first cell of the first row of each set of three rows and pasting into the two newly created cells beneath it.

The reason for this so that the data in a given column can then be copied and pasted into a different workbook and fit in with it's formatting.

Below is an example of what was recorded with the "Record Macro" button:

'Now, add spaces between PRC CTs from wb1:
    wb1.Sheets(1).Activate
    Range("H5:H6").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("H8:H9").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("H11:H12").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("H14:H15").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

I just have this repeating 12 times, but want a loop until the last row of data instead as I discussed above.

Below is an example of the copy and paste I discussed. I'd like to learn how to convert this into a loop as well.

'Now, repeat PRC ct results in triplicate:
    wb1.Sheets(1).Range("H4").Copy
    wb1.Sheets(1).Range("H5").PasteSpecial
    wb1.Sheets(1).Range("H6").PasteSpecial

    wb1.Sheets(1).Range("H7").Copy
    wb1.Sheets(1).Range("H8").PasteSpecial
    wb1.Sheets(1).Range("H9").PasteSpecial
    
    wb1.Sheets(1).Range("H10").Copy
    wb1.Sheets(1).Range("H11").PasteSpecial
    wb1.Sheets(1).Range("H12").PasteSpecial

As an example, here is a screen grab of what these two codes work together to do:
Capture.JPG Before the codes ran, it was simply three rows that read: 30.5409, 32.2871, 0.

Thanks for any advice or suggestions!
Kris

[SamT]

Basic loops:
For... To... Next
Do... While... Loop
For Each... In...

Your example done my way requires a complex set of instructions. This assumes that the region under the area is already empty. However it allows any sized range to be worked with. ("H4" to ("H???")

'Off the top of my head
Dim MyArray as variant
Dim i as long  Always use Longs for Row and Column counters
Dim j As Long: j = 4 'Initialized to starting row

With wb1.Sheets(1)
MyArray = .Range("H4:H15").Value 'H15 Correct?

for i = LBound(MyArray) to UBound(MyArray)
.Range("H" & j).Resize(3,1) = MyArray(i)
j = j + 3
next i

End with

To accomplish the same by inserting 2 rows beneath each row of data is far more complex and should be done from bottom to top.

[Paul_Hossler]

Excel and VBA can be fun

Ask the forum any questions

Try the loop below

Option Explicit

Sub InsertCopyRows()
    Dim rCellToCopy As Range
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        'find last cellwith data in H by going to end of sheet and coming up
        Set rCellToCopy = .Cells(.Rows.Count, 8).End(xlUp)  '   (H6)
    
        Do While rCellToCopy.Row >= 4
        
            'get that row
            rCellToCopy.EntireRow.Copy  '(6:6)
        
            'tricky part - go down 1 cell (H7), get 2 rows and 1 column (H7:H8), then the whole rows (7:8:), and insert the copy into the two rows
            rCellToCopy.Offset(1, 0).Resize(2, 1).EntireRow.Insert Shift:=xlDown
        
            'now go to the cell above (i.e. the -1) we Set (remembered) above, i.e. H5
            Set rCellToCopy = rCellToCopy.Offset(-1, 0)
            'after we do the H4 cell, the -1 gives us H3 with row = 3 the the Do While is no 'While' any more
            
        Loop
    
    End With
    
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Notice that you don't need to .Select or .Activate for most things -- just act on the object

[krisbowls]

Paul,
Thanks, your code works nicely, but I didn't explain exactly what I was doing correctly. I'm just inserting cells below as opposed to whole new rows. What do I need to edit to make your code only insert new cells below instead of inserting rows?

Thanks so much!

[Paul_Hossler]

To not do the entire row, just delete the 2 .EntireRow pieces

Option Explicit
Sub InsertCopyRows()
    Dim rCellToCopy As Range
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        'find last cellwith data in H by going to end of sheet and coming up
        Set rCellToCopy = .Cells(.Rows.Count, 8).End(xlUp)  '   (H6)
    
        Do While rCellToCopy.Row >= 4
        
            'get that row
            rCellToCopy.Copy  '(H6 at fist)
        
            'tricky part - go down 1 cell (H7), get 2 rows and 1 column (H7:H8), and insert the copy into the two cells
            rCellToCopy.Offset(1, 0).Resize(2, 1).Insert Shift:=xlDown
        
            'now go to the cell above (i.e. the -1) we Set (remembered) above, i.e. H5
            Set rCellToCopy = rCellToCopy.Offset(-1, 0)
            'after we do the H4 cell, the -1 gives us H3 with row = 3 then the Do While is no 'While' any more
            
        Loop
    
    End With
    
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[krisbowls]

Ok, that's what I suspected and it seems to work smoothly now, thank you!