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