PDA

View Full Version : [SOLVED] VBA Loop



krisbowls
02-21-2018, 12:57 PM
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:
21676 Before the codes ran, it was simply three rows that read: 30.5409, 32.2871, 0.

Thanks for any advice or suggestions!
Kris

SamT
02-21-2018, 01:53 PM
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
02-21-2018, 02:10 PM
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
02-22-2018, 08:49 AM
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
02-22-2018, 09:13 AM
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
02-22-2018, 01:14 PM
Ok, that's what I suspected and it seems to work smoothly now, thank you!