Extend Macro

Brian from Maui

Brian from Maui

MrExcel MVP
Joined
Feb 16, 2002
Messages
8,459
Aloha,

I recorded the following macro and would like to extend the macro to row 1,000. The macro inserts a row, deletes column C, then cuts cells A5 and B5 and paste the cells in F2 and G2. It then deletes 8 rows.

Then it repeats the process

Thanks

Code: 
Sub Macro1()
'
' Macro1 Macro
'
'
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Range("A5:B5").Select
    Selection.Cut
    Range("F2").Select
    ActiveSheet.Paste
    Rows("3:10").Select
    Selection.Delete Shift:=xlUp
    Range("A6:B6").Select
    Selection.Cut
    Range("F3").Select
    ActiveSheet.Paste
    Rows("4:11").Select
    Selection.Delete Shift:=xlUp
    Range("A7:B7").Select
    Selection.Cut
    Range("F4").Select
    ActiveSheet.Paste
    Rows("5:12").Select
    Selection.Delete Shift:=xlUp
    Range("A8:B8").Select
    Selection.Cut
    Range("F5").Select
    ActiveSheet.Paste
    Rows("6:13").Select
    Selection.Delete Shift:=xlUp
    Range("A9:B9").Select
    Selection.Cut
    Range("F6").Select
    ActiveSheet.Paste
    Rows("7:14").Select
    Selection.Delete Shift:=xlUp
    Range("A10:B10").Select
    Selection.Cut
    Range("F7").Select
    ActiveSheet.Paste
    Rows("8:15").Select
    Selection.Delete Shift:=xlUp
    Range("A11:B11").Select
    Selection.Cut
    Range("F8").Select
    ActiveSheet.Paste
    Rows("9:16").Select
    Selection.Delete Shift:=xlUp
    Range("A12:B12").Select
    Selection.Cut
    Range("F9").Select
    ActiveSheet.Paste
End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
First and foremost, you need to get rid of all of the Select/Selection operations. They are not necessary in the macro. Excel records them because that is literally what you are doing, but for efficient macro operation, this is all you need:
Rich (BB code): 
Sub Macro1()
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Range("A5:B5").Cut Destination:=Range("F2")
    Rows("3:10").Delete Shift:=xlUp
    Range("A6:B6").Cut Destination:=Range("F3")
    Rows("4:11").Delete Shift:=xlUp
    Range("A7:B7").Cut Destination:=Range("F4")
    Rows("5:12").Delete Shift:=xlUp
    Range("A8:B8").Cut Destination:=Range("F5")
    Rows("6:13").Delete Shift:=xlUp
    Range("A9:B9").Cut Destination:=Range("F6")
    Rows("7:14").Delete Shift:=xlUp
    Range("A10:B10").Cut Destination:=Range("F7")
    Rows("8:15").Delete Shift:=xlUp
    Range("A11:B11").Cut Destination:=Range("F8")
    Rows("9:16").Delete Shift:=xlUp
    Range("A12:B12").Cut Destination:=Range("F9")
End Sub

With that out of the way, it looks like you need a For loop to perform this operation multiple times. Try this on a copy of your data, because I did not actually test this.

Rich (BB code): 
Sub Macro2()
    Const iMAX_ROW As Long = 1000
    
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Dim iCutCells As Long
    Dim iDestCells As Long
    Dim iDeleteCellsStart As Long
    Dim iDeleteCellsEnd As Long
    
    Dim i As Long
    
    iCutCells = 5
    iDestCells = 2
    iDeleteCellsStart = 3
    iDeleteCellsEnd = 10
    
    For i = 0 To iMAX_ROW - 1
      Range("A" & iCutCells + i & ":B" & iCutCells + i).Cut Destination:=Range("F" & iDestCells)
      Rows(iDeleteCellsStart + i & ":" & iDeleteCellsEnd + i).Delete Shift:=xlUp
    Next i
End Sub

You may need to change iMAX_ROW to a smaller number, based on the number of rows you are deleting. So instead of 1000, it may only need to be 1000 / (10-3) ~= 143.
 
Last edited:
Upvote 0
iliace said:
First and foremost, you need to get rid of all of the Select/Selection operations. They are not necessary in the macro. Excel records them because that is literally what you are doing, but for efficient macro operation, this is all you need:
Rich (BB code): 
Sub Macro1()
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Range("A5:B5").Cut Destination:=Range("F2")
    Rows("3:10").Delete Shift:=xlUp
    Range("A6:B6").Cut Destination:=Range("F3")
    Rows("4:11").Delete Shift:=xlUp
    Range("A7:B7").Cut Destination:=Range("F4")
    Rows("5:12").Delete Shift:=xlUp
    Range("A8:B8").Cut Destination:=Range("F5")
    Rows("6:13").Delete Shift:=xlUp
    Range("A9:B9").Cut Destination:=Range("F6")
    Rows("7:14").Delete Shift:=xlUp
    Range("A10:B10").Cut Destination:=Range("F7")
    Rows("8:15").Delete Shift:=xlUp
    Range("A11:B11").Cut Destination:=Range("F8")
    Rows("9:16").Delete Shift:=xlUp
    Range("A12:B12").Cut Destination:=Range("F9")
End Sub

With that out of the way, it looks like you need a For loop to perform this operation multiple times. Try this on a copy of your data, because I did not actually test this.

Rich (BB code): 
Sub Macro2()
    Const iMAX_ROW As Long = 1000
    
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Dim iCutCells As Long
    Dim iDestCells As Long
    Dim iDeleteCellsStart As Long
    Dim iDeleteCellsEnd As Long
    
    Dim i As Long
    
    iCutCells = 5
    iDestCells = 2
    iDeleteCellsStart = 3
    iDeleteCellsEnd = 10
    
    For i = 0 To iMAX_ROW - 1
      Range("A" & iCutCells + i & ":B" & iCutCells + i).Cut Destination:=Range("F" & iDestCells)
      Rows(iDeleteCellsStart + i & ":" & iDeleteCellsEnd + i).Delete Shift:=xlUp
    Next i
End Sub

You may need to change iMAX_ROW to a smaller number, based on the number of rows you are deleting. So instead of 1000, it may only need to be 1000 / (10-3) ~= 143.
Click to expand...

Aloha iliace,

This works except it does not cut from Columns A5:B5 and paste in Columns F2 and so on.

Appreciate you looking at this. My co-worker has been cutting/pasting and deleting data over 2,000 rows
 
Upvote 0
How about
Code: 
Sub Macro1()
   Dim i As Long

   Rows("1:1").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   Columns("C:C").Delete shift:=xlToLeft
   For i = 5 To 1000
      Range("A" & i).Resize(, 2).Copy Range("F" & i - 3)
      Rows(i - 2 & ":" & i + 5).Delete
   Next i

End Sub
 
Upvote 0
Fluff said:
How about
Code: 
Sub Macro1()
   Dim i As Long

   Rows("1:1").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   Columns("C:C").Delete shift:=xlToLeft
   For i = 5 To 1000
      Range("A" & i).Resize(, 2).Copy Range("F" & i - 3)
      Rows(i - 2 & ":" & i + 5).Delete
   Next i

End Sub
Click to expand...


AWESOME Fluff. Mahalo!

Thanks iliace for your time. Appreciate both your help.
 
Upvote 0
Glad we could help & thanks for the feedback
 
Upvote 0
Nice one, Fluff!
As for my code, I realize I made one minor omission that is probably causing the issue. See in red below.
Rich (BB code): 
Sub Macro2()
    Const iMAX_ROW As Long = 1000
    
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Dim iCutCells As Long
    Dim iDestCells As Long
    Dim iDeleteCellsStart As Long
    Dim iDeleteCellsEnd As Long
    
    Dim i As Long
    
    iCutCells = 5
    iDestCells = 2
    iDeleteCellsStart = 3
    iDeleteCellsEnd = 10
    
    For i = 0 To iMAX_ROW - 1
      Range("A" & iCutCells + i & ":B" & iCutCells + i).Cut Destination:=Range("F" & iDestCells + i)
      Rows(iDeleteCellsStart + i & ":" & iDeleteCellsEnd + i).Delete Shift:=xlUp
    Next i
End Sub

Academic at this point, but figured I'd post the correction for sake of completeness :)
 
Upvote 0
iliace said:
Nice one, Fluff!
As for my code, I realize I made one minor omission that is probably causing the issue. See in red below.
Rich (BB code): 
Sub Macro2()
    Const iMAX_ROW As Long = 1000
    
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Delete Shift:=xlToLeft
    
    Dim iCutCells As Long
    Dim iDestCells As Long
    Dim iDeleteCellsStart As Long
    Dim iDeleteCellsEnd As Long
    
    Dim i As Long
    
    iCutCells = 5
    iDestCells = 2
    iDeleteCellsStart = 3
    iDeleteCellsEnd = 10
    
    For i = 0 To iMAX_ROW - 1
      Range("A" & iCutCells + i & ":B" & iCutCells + i).Cut Destination:=Range("F" & iDestCells + i)
      Rows(iDeleteCellsStart + i & ":" & iDeleteCellsEnd + i).Delete Shift:=xlUp
    Next i
End Sub

Academic at this point, but figured I'd post the correction for sake of completeness :)
Click to expand...


Works as well................thanks :ROFLMAO:
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Help with Vba Code
Replies
3
Views
159
Coyotex3
C
C
  • Solved
Replace fixed location in MACRO with user selection
Replies
3
Views
126
CordingBags
C
S
  • Solved
Copy row 2 and paste it after last row of another worksheet
Replies
9
Views
873
rollis13
rollis13
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
208
Coco1
C
G
  • Question
Macro to cut entire row form table depending on the value of column "M" and paste on another table
Replies
3
Views
306
kevin9999
K

Forum statistics

Threads
1,214,935
Messages
6,122,337
Members
449,078
Latest member
skydd

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