Cut specific rows and paste to new workbook faster 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" &amp; transfer_row) = "value1"

            Workbooks(old_workbook).Worksheets(old_sheet).Range(transfer_row &amp; ":" &amp; transfer_row).Cut _
                Workbooks(new_workbook1).Worksheets("Sheet1").Range("A" &amp; new_transfer)

            new_transfer = new_transfer + 1

            Workbooks(old_workbook).Worksheets(old_sheet).Activate
            Rows(transfer_row &amp; ":" &amp; transfer_row).Delete Shift:=x1Up

        Loop
        Next transfer_row

    Workbooks(new_workbook1).Activate

End Sub
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" &amp; transfer_row) = ""
    Transfer_Value = Range("L" &amp; transfer_row)
    Select Case Transfer_Value
        Case "value1", "value2"
            Workbooks(old_workbook).Worksheets(old_sheet).Range(transfer_row &amp; ":" &amp; transfer_row).Cut _
                Workbooks(Transfer_Value).Worksheets("Sheet1").Range("A" &amp; 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.