VBA macro error

Ed in Aus

Well-known Member
Joined
Jul 24, 2007
Messages
829
I have a VBA project that basically filters on column A (position numbers) and then adds up column 5 (costing %) this project sends an error back to the user if column 5 does not equal 100%. It usual works fine but with these numbers it doesn't... the columns in the centre are costing codes (not relevant) any ideas
15902 295000 295110 71001 25
15902 295000 295110 71002 16.67
15902 295000 295110 71003 41.66
15902 295000 295110 71006 16.67
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

tactps

Well-known Member
Joined
Jan 20, 2004
Messages
3,460
Are you sure that the numbers are rounded to 2 decimals (if not then it will not equal 100, therefore you will get an error message)?

It would also be useful if you posted your macro and worksheet.
 

Ed in Aus

Well-known Member
Joined
Jul 24, 2007
Messages
829
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
 

tactps

Well-known Member
Joined
Jan 20, 2004
Messages
3,460
try changing:
percent = Cells(rw, 5) + percent
to
percent = round(Cells(rw, 5),2) + percent

Also, check that the numbers are properly rounded, by using this formula (assuming A1) holds the data:
=round(a1,2)=a1
If true, then all is ok. If false, then you have a rounding issue.
 

Ed in Aus

Well-known Member
Joined
Jul 24, 2007
Messages
829
Hi Tactps,

Tried it and still gives me the message box error that it doesn't add to 100 percent,
 

tactps

Well-known Member
Joined
Jan 20, 2004
Messages
3,460
Did you check that each line is rounded properly, i.e.:

Also, check that the numbers are properly rounded, by using this formula (assuming A1) holds the data:
=round(a1,2)=a1
If true, then all is ok. If false, then you have a rounding issue.
 

Ed in Aus

Well-known Member
Joined
Jul 24, 2007
Messages
829
Checked the column, all came back true... what else could be doing this??
 

rbrhodes

Board Regular
Joined
May 25, 2007
Messages
69
Hello.

It's not actually a rounding error it's the variable declaration. 'percent' is Dim'd as Integer so 16.67 is 17, 41.66 is 42, etc. So each of the three decimal numbers is adding 1/3 for a grand total of 101 (which is not 100 <G>) BTW: Long won't do it either.

Simply Dim percent as double to handle the decimal points and you're good to go. ie:

Dim rw As Integer
Dim user As String
Dim position As String

Dim percent As Double
 

tactps

Well-known Member
Joined
Jan 20, 2004
Messages
3,460
On review, I think you have an issue because you have:
Dim percent As Integer

This only allows whole numbers.

Remove this line, re-run and advise.
 

Forum statistics

Threads
1,181,648
Messages
5,931,213
Members
436,784
Latest member
amuljono

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
Top