Need macro to run faster

User Name Active

New Member
Joined
Jan 29, 2014
Messages
19
This is a really long macro, but it does exactly what I need it to do. Problem is it takes 7s to run. It enters a new time entry when a user presses enter. I need it to run faster as the user may be putting a lot of entries in at one time.



Code:
Sub Enter_Input()
    Dim CalcMode              As Long

  With Application
        .ScreenUpdating = False
        CalcMode = .Calculation
    End With

If Sheets("Labor Hours").Range("D4") = "" Then
    MsgBox "You must enter a date"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D5") = "" Then
    MsgBox "You must enter a type"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D6") = "" Then
    MsgBox "You must enter a company"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D8") = "" Then
    MsgBox "You must enter a shift"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D7") = "" And Sheets("Labor Hours").Range("D5") = "Crew" Then
    MsgBox "You must enter a name"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D7") = "" And Sheets("Labor Hours").Range("D5") = "Subcontractor" Then
    MsgBox "You must enter a name"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D9") = "" And Sheets("Labor Hours").Range("D5") = "Crew" Then
    MsgBox "You must enter a billing craft"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D10") = "" And Sheets("Labor Hours").Range("D5") = "Crew" Then
    MsgBox "You must enter a actual craft"
    Exit Sub
Else
If Sheets("Labor Hours").Range("D11") = "" Then
    MsgBox "You must enter a purchase order"
    Exit Sub
Else
'______________________________________________
'Unlock Sheets

Sheets("Summary").Unprotect "Elliott1"
Sheets("Customer").Unprotect "Elliott1"
'______________________________________________
'Copy Lines Over

Sheets("Labor Hours").Range("$D$14:$D$16").Copy
Range("$D$14:$D$16").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, skipBlanks:=False, Transpose:=False
    
Range("$D$19:$D$21").Copy
Range("$D$19:$D$21").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, skipBlanks:=False, Transpose:=False
                                                
Range("$C$24:$D$34").Copy
Range("$C$24:$D$34").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, skipBlanks:=False, Transpose:=False
                                                
Range("$H$14:$H$34").Copy
Range("$H$14:$H$34").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, skipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'______________________________________________
'Loop Delete
    With Sheets("Crew Log")

        Firstrow = .UsedRange.Cells(1).Row
        lastrow = .UsedRange.Rows(.UsedRange.Rows.count).Row

        For Lrow = lastrow To Firstrow Step -1
            With .Cells(Lrow, "A")
                If Not IsError(.Value) Then
                If .Value = "1" Then .EntireRow.Delete
                   
                End If
            End With
        Next Lrow
    End With
    
'______________________________________________
'Copy Paste
    Sheets("Labor Hours").Range("$A$38:$BA$38").Copy
    Sheets("Crew Log").Range("L65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
                                                Operation:=xlNone, skipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

'______________________________________________
'Repaste Formulas

    lastrow = Sheets("Crew Log").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    For Each rng In Sheets("Crew Log").Range("L2:L" & lastrow)
        If rng <> "" Then
            Sheets("Storage").Range("A2:K2").Copy Sheets("Crew Log").Cells(rng.Row, 1)
            Sheets("Storage").Range("BM2:DO2").Copy Sheets("Crew Log").Range("BM:DO").Cells(rng.Row, 1)
         
        End If
    Next rng

'______________________________________________
'Calculate Sheet
    Sheets("Labor Hours").Calculate
    
'______________________________________________

    Dim ws                    As Worksheet
    Set ws = ActiveWorkbook.Worksheets("Crew Log")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("M1"), SortOn:=xlSortOnValues, _
                 Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange ws.Range("L2:BL10000")
        .Header = xlNo
        .matchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

'______________________________________________
'Restructure

'Unique
 
Sheets("Restructure").Range("A:C").ClearContents
 Sheets("Crew Log").Range("O:O").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Restructure").Range("A1"), Unique:=True
 Sheets("Crew Log").Range("P:P").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Restructure").Range("B1"), Unique:=True
 Sheets("Crew Log").Range("T:T").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Restructure").Range("C1"), Unique:=True

'Auto Sort A

    Set ws = ActiveWorkbook.Worksheets("Restructure")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("A1"), SortOn:=xlSortOnValues, _
                 Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange ws.Range("A2:A10000")
        .Header = xlNo
        .matchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

'Auto Sort B

    Set ws = ActiveWorkbook.Worksheets("Restructure")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("B1"), SortOn:=xlSortOnValues, _
                 Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange ws.Range("B2:B10000")
        .Header = xlNo
        .matchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

'Auto Sort C

    Set ws = ActiveWorkbook.Worksheets("Restructure")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("C1"), SortOn:=xlSortOnValues, _
                 Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange ws.Range("C2:C10000")
        .Header = xlNo
        .matchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

'Paste All

Sheets("Restructure").Range("A1:C1") = "All"

'______________________________________________
    
'Fill In

'Clear
    
Sheets("Summary").Range("A43:T10035").EntireRow.Delete
Sheets("Customer").Range("A11:T10000").EntireRow.Delete

'Copy Formula Summary

Sheets("Summary").Unprotect "Elliott1"
 With Sheets("Summary")
    .Rows(42).Copy .Rows(43).Resize(Sheets("Restructure").Range("G1"))
End With
 Application.CutCopyMode = False

'Copy Formulas Customer
 
 With Sheets("Customer")
    .Rows(10).Copy .Rows(11).Resize(Sheets("Restructure").Range("H1"))
End With
 Application.CutCopyMode = False

'______________________________________________
'Hide unused PO lines

Sheets("Summary").Unprotect "Elliott1"
    BeginRow = 6
    EndRow = 29
    ChkCol = 4

    For RowCnt = BeginRow To EndRow
       If Sheets("Summary").Cells(RowCnt, ChkCol).Value = 0 Then
            Sheets("Summary").Cells(RowCnt, ChkCol).EntireRow.Hidden = True
   Else
    Sheets("Summary").Cells(RowCnt, ChkCol).EntireRow.Hidden = False
        End If
    Next RowCnt

'______________________________________________

Sheets("Summary").Protect "Elliott1"
Sheets("Customer").Protect "Elliott1"
'______________________________________________
    
  With Application
        .Calculation = CalcMode
        .ScreenUpdating = True
    End With
    End If
    End If
    End If
    End If
    End If
    End If
    End If
    End If
    End If
    
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Try stepping into this sub in the VBA editor. Select the sub and use the F5 key. You will see your sticking points. I will look into it further and see if anything stands out.
 
Upvote 0
Code:
    Dim ws                    As Worksheet
    Set ws = ActiveWorkbook.Worksheets("Crew Log")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("M1"), SortOn:=xlSortOnValues, _
                 Order:=xlAscending, DataOption:=xlSortNormal
        End With
[B]        .SetRange ws.Range("L2:BL10000")
[/B]        .Header = xlNo
        .matchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

   End With

Suspect number 1
 
Upvote 0
A number big ranges being used. I would generally avoid using "usedrange" as well - Excel can sometimes extend this far beyond what you expect. Better to dynamically size the ranges you are working with to minimise unnecessary processing.
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,317
Members
448,564
Latest member
ED38

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