The macro itself is rather long but here it is,
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" ( _
ByVal buffer As String, _
ByRef size As Long) As Long
Public Property Get UserName() As String
Dim buffer As String * 255
Dim result As Long
Dim length As Long
length = 255
result = GetUserName(buffer, length)
If length > 0 Then UserName = Left(buffer, length - 1)
End Property
Sub Check_and_Send()
Dim rw As Integer
Dim position As String
Dim percent As Integer
Dim user As String
user = UserName
rw = 2
'sorts by position number
Range("A2:E5000").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
'checks position # length and alerts if short
Do While Cells(rw, 1) <> ""
position = Cells(rw, 1)
If Len(position) <> 5 Then
MsgBox ("Position number " & position & " on row " & rw & " is not 5 digits long. Please amend and restart Send and Check.")
Cells(rw, 1).Activate
End
End If
rw = rw + 1
Loop
'checks for blank BTZ and Project
rw = 2
Do While Cells(rw, 1) <> ""
position = Cells(rw, 1)
If Cells(rw, 2) = "" Then
Cells(rw, 2).Select
MsgBox ("Position number " & position & " has a blank BTZ. Please enter the BTZ and restart Check and Send")
End
If Len(Cells(rw, 2)) <> 6 Then
Cells(rw, 2).Select
MsgBox ("Position number " & position & " BTZ is not 6 digits long. Please amend the BTZ and restart Check and Send")
End
End If
End If
'project
If Cells(rw, 3) = "" Then
Cells(rw, 3).Select
MsgBox ("Position number " & position & " has a blank Project. Please enter the Project and restart Check and Send")
End
If Len(Cells(rw, 3)) <> 6 Then
Cells(rw, 3).Select
MsgBox ("Position number " & position & " Project Code is not 6 digits long. Please amend the Project Code and restart Check and Send")
End
End If
End If
'checks sub project, adds 0 if blank alerts if not 5 digits
If Cells(rw, 4) = "" Then
Cells(rw, 4) = "0"
End If
If Len(Cells(rw, 4)) <> 5 And Cells(rw, 4) <> "0" Then
MsgBox ("Position number " & position & " sub-project is not 5 digits. Please amend the Sub-project and restart Check and Send")
Cells(rw, 4).Activate
End
End If
rw = rw + 1
Loop
'calculates total % of each position
rw = 2
Do While Cells(rw, 1) <> ""
percent = 0
position = Cells(rw, 1)
Do While Cells(rw, 1) = position
percent = Cells(rw, 5) + percent
rw = rw + 1
Loop
If percent <> 100 Then
Cells(rw - 1, 5).Select
MsgBox ("The percentage for position " & position & " does not equal 100. Please adjust and restart Check and Send")
End
End If
Loop
'sends checked sheet to Aurion Systems Team
ChDir "H:\"
ActiveWorkbook.SaveAs Filename:="H:\Costing " & user & " " & Format(Date, "ddmmyy") & ".xls", FileFormat:=xlNormal, Password:= _
"", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:= _
False
ActiveWorkbook.SendMail Recipients:="email.address@123.fake.street", Subject:="Costing upload file"
End Sub
