2
\$\begingroup\$

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
\$\endgroup\$
1

2 Answers 2

1
\$\begingroup\$

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.

\$\endgroup\$
1
\$\begingroup\$

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.

\$\endgroup\$
1
  • \$\begingroup\$ Good suggestions Michael... \$\endgroup\$
    – MatthewD
    Commented May 4, 2016 at 22:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.