Cut specific rows and paste to new workbook faster

Question

I'm quite new to trying to write my own macros and I've been able to piece this one together, but it takes quite some time to run. Here is the macro for one value (I have to create workbooks for ~20 different values). Are there any ways I can improve its speed?

Also, I am assuming I can just replicate my For/Next loop with new values and workbooks and not have to run this macro every time with a new value. So if not, please tell me I'm being naive.

Sub MakeRecruitCommLog()
 Application.ScreenUpdating = False
 old_workbook = ActiveWorkbook.Name
 old_sheet = ActiveSheet.Name
 Workbooks.Add
 new_workbook1 = ActiveWorkbook.Name
 Workbooks(old_workbook).Activate
 Rows("1:1").Select
 Selection.Copy
 Workbooks(new_workbook1).Activate
 Range("A1").Select
 ActiveSheet.Paste
 Dim transfer_row As Long
 new_transfer = 2
 Workbooks(old_workbook).Activate
 For transfer_row = 2 To 514000
 Do While Range("L" & transfer_row) = "value1"
 Workbooks(old_workbook).Worksheets(old_sheet).Range(transfer_row & ":" & transfer_row).Cut _
 Workbooks(new_workbook1).Worksheets("Sheet1").Range("A" & new_transfer)
 new_transfer = new_transfer + 1
 Workbooks(old_workbook).Worksheets(old_sheet).Activate
 Rows(transfer_row & ":" & transfer_row).Delete Shift:=x1Up
 Loop
 Next transfer_row
 Workbooks(new_workbook1).Activate
End Sub

• MatthewD: Find the last used row with data in column L and loop to that instead of 514000. But even better you can do a find on the L column for the "value1" and loop the find results. Find loop example msdn.microsoft.com/en-us/library/office/ff839746.aspx find last row examples stackoverflow.com/questions/11926972/…

Answer 1

I heartily recommend dropping the Select and Activate statements throughout - they are not required and will speed up your VBA quite dramatically. Michael's suggestions are also worth implementing.

Answer 2

For one thing, I think you should do all 20 values all at once, in a single loop. First, create the workbooks so you can access them:

Workbooks.Add
ActiveWorkbook.Name = "value1"
Workbooks.Add
ActiveWorkbook.Name = "value2"

Then you can just check the value against one of the workbook names instead:

transfer_row = 2
Dim Transfer_Value as String
Do Until Range("L" & transfer_row) = ""
 Transfer_Value = Range("L" & transfer_row)
 Select Case Transfer_Value
 Case "value1", "value2"
 Workbooks(old_workbook).Worksheets(old_sheet).Range(transfer_row & ":" & transfer_row).Cut _
 Workbooks(Transfer_Value).Worksheets("Sheet1").Range("A" & new_transfer)
 Workbooks(old_workbook).Worksheets(old_sheet).Rows(transfer_row).Delete Shift:=xlUp
 Case Else
 transfer_row = transfer_row + 1
 End Select
Loop

If you have an array or something with the different values in it, you could use that instead of a massive Case string.

• MatthewD: Good suggestions Michael...