I have written a VBA function to calculate the weight of a determine the weight of a certain item from its model number by comparing it to the model number of items with known weights. For some reason it is only returning #NAME?
Here is the code:
Function getWeight(model As String) As Double
Dim weight As Double
weight = -1#
Dim compModel As String
compModel = ""
Dim prevNumMatches As Integer
prevNumMatches = 0
Dim numMatches As Integer
numMatches = 0
Dim i As Integer
Dim p As Integer
Dim samePump As Boolean
Dim sameMotor As Boolean
Dim special As Boolean
For i = 2 To 1000
compModel = CStr(Sheets("Weights").Cells(i, 1).Value)
For p = 1 To Len(compModel)
samePump = False
sameMotor = False
special = False
numMatches = 0
If p = 1 Then
If Mid(model, p, 1) = Mid(compModel, p, 1) Then
samePump = True
numMatches = numMatches + 1
End If
ElseIf p = 5 Then
If Mid(model, p, 1) <> "-" Then
special = True
End If
If Mid(model, p, 1) = Mid(compModel, p, 1) Then
numMatches = numMatches + 1
End If
ElseIf p = 9 Then
If Mid(model, p, 1) = Mid(compModel, p, 1) Then
sameMotor = True
numMatches = numMatches + 1
End If
Else
If Mid(model, p, 1) = Mid(compModel, p, 1) Then
numMatches = numMatches + 1
End If
End If
If samePump And (sameMotor Or special) Then
If numMatches > prevNumMatches Then
weight = CDbl(Sheets("Weights").Cells(i, 2).Value)
prevNumMatches = numMatches
ElseIf numMatches = prevNumMatches Then
If CDbl(Sheets("Weights").Cells(i, 2).Value) > weight Then
weight = CDbl(Sheets("Weights").Cells(i, 2).Value)
End If
End If
End If
Next p
Next i
If weight = -1# Then
getWeight = 0#
Else
getWeight = weight
End If
End Function
Why is this not returning a number as I expect?
Each iteration of the
p = 1 to len(compmodel)
loop resets all your Booleans to false. This means the statement
If samePump And (sameMotor Or special) Then
is never true because it never evaluates all of those on the same pass of the loop. Put the boolean setters before the start of the loop instead of in it.
samePump = False
sameMotor = False
special = False
numMatches = 0
For p = 1 To Len(compModel)
Also if you did want to use the debugger just run this. That way you can step through the code line by line and see whats going on.
Sub main()
Dim THingy As Double
THingy = getWeight("R221-FT-AA1")
MsgBox (THingy)
End Sub
The function is (implicitly) Public, so the only way to get a #NAME? error is to implement it in the wrong type of module, such that Excel doesn't know what =getWeight is referring to.
You need to add a standard procedural module (.bas) to your project, cut the function, and paste it in there.
Bugs aside, you should be able to call your UDF from the worksheet.
ThisWorkbook, as well as all Worksheet modules, UserForm modules, and plain class modules, are blueprints for objects, which means in order to call their public members you need to qualify the member calls with an instance of that class... and a UDF (or macro for that matter) call can't do that.
I found the problem. Even though the file was saved as a macro enabled workbook (.xlsm) macros were not enabled. When I reopened it this morning, it gave me the option to enable macros. Once I did that and corrected the code as Jared suggested, it all worked as planned.
Related
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question does not appear to be about programming within the scope defined in the help center.
Closed 4 years ago.
Improve this question
I have the following code that searches through folder directories in a DataGridView table, and puts all files of the wanted format into a list, it also gathers a list of their last modified date for later use in the application.
The code works, but it is sore on the eyes. I want to tidy up the following loops to improve efficiency - what I mean is that I have a For loop within a For loop that creates the list of filenames, then I have two separate Do Until loops that search through the list from start to finish to pick out file names that need adjustment.
I would be very interested to learn a better way of achieving the same result, as my knowledge of efficiency in coding is quite elementary. Basically, can this be done in one or two loops, as the idea of looping through the Lists twice seems inefficient?
Public Class
Private Sub btnDirectory_Click(sender As Object, e As EventArgs) Handles btnDirectory.Click
Dim FileNames As New List(Of String)
Dim FileDates As New List(Of Date)
Dim DocNo As String
Dim rowCheck As String
Dim ProjectNo As String = "1111"
Dim FileNameCheck As String
Dim str As String
Dim k As Integer = 0
Dim i As Integer
Dim j As Integer
Dim CorrectType As Boolean = False
'The first loop grabs all files of the wanted format from a datagridview table containing all directories to be checked
For Each rw In Background.Table1.Rows
rowCheck = Background.Table1(0, k).Value
If Not String.IsNullOrEmpty(rowCheck) Then
For Each file As String In My.Computer.FileSystem.GetFiles(Background.Table1(0, k).Value)
CorrectType = False
FileNameCheck = IO.Path.GetFileNameWithoutExtension(file)
If FileNameCheck.Contains(ProjectNo) AndAlso FileNameCheck.Contains("-") AndAlso Not String.IsNullOrEmpty(FileNameCheck) AndAlso FileNameCheck.Contains(" ") Then
DocNo = FileNameCheck.Substring(0, FileNameCheck.IndexOf(" "))
If FileNameCheck.Substring(0, FileNameCheck.IndexOf("-")) = ProjectNo AndAlso CountLetters(DocNo) = 3 Then
CorrectType = True
End If
End If
If CorrectType = True Then
FileNames.Add(FileNameCheck)
FileDates.Add(IO.File.GetLastWriteTime(file))
End If
Next
End If
k += 1
Next
'The next loop tidies up the file formats that contain a "-00-" in their names
j = FileNames.Count
i = 0
Do
str = FileNames(i)
If str.Contains("-00-") Then
FileNames(i) = RemoveChar(str, "-00-") ' RemoveChar is a function that replaces "-00-" with a "-"
End If
i += 1
Loop Until i = j
i = 0
j = FileNames.Count
'Finally, this loop checks that no two files have the exact same name, and gets rid of one of them if that is the case
Do
Dim st1 As String = FileNames(j - 1)
Dim st2 As String = FileNames(j - 2)
If st1 = st2 Then
FileNames.RemoveAt(j - 1)
FileDates.RemoveAt(j - 1)
End If
j -= 1
Loop Until j = 1
End Sub
End Class
The code is certainly hard on the eyes.
the For Each rw loop does not use rw. You could replace this with a loop such as:
For k = 1 to Background.Table1.Rows.Count
' Do things here
Next k
You assign rowCheck and use it once, but you missed the opportunity to reuse it in the For Each file line.
Where you have CorrectType = True you can easily place the corresponding code instead.
If FileNameCheck.Substring(0, FileNameCheck.IndexOf("-")) = ProjectNo AndAlso CountLetters(DocNo) = 3 Then
CorrectType = True
End If
End If
If CorrectType = True Then
FileNames.Add(FileNameCheck)
FileDates.Add(IO.File.GetLastWriteTime(file))
End If
becomes:
If FileNameCheck.Substring(0, FileNameCheck.IndexOf("-")) = ProjectNo AndAlso CountLetters(DocNo) = 3 Then
FileNames.Add(FileNameCheck)
FileDates.Add(IO.File.GetLastWriteTime(file))
End If
I must admit, the next two loops made my eyes bleed (figuratively, not literally).
j = FileNames.Count
i = 0
Do
str = FileNames(i)
If str.Contains("-00-") Then
FileNames(i) = RemoveChar(str, "-00-") ' RemoveChar is a function that replaces "-00-" with a "-"
End If
i += 1
Loop Until i = j
becomes
for i = 1 to FileNames.Count
str = FileNames(i)
If str.Contains("-00-") Then
FileNames(i) = RemoveChar(str, "-00-") ' RemoveChar is a function that replaces "-00-" with a "-"
End If
Next I
And
i = 0
j = FileNames.Count
'Finally, this loop checks that no two files have the exact same name, and gets rid of one of them if that is the case
Do
Dim st1 As String = FileNames(j - 1)
Dim st2 As String = FileNames(j - 2)
If st1 = st2 Then
FileNames.RemoveAt(j - 1)
FileDates.RemoveAt(j - 1)
End If
j -= 1
Loop Until j = 1
becomes
'Finally, this loop checks that no two files have the exact same name, and gets rid of one of them if that is the case
For j = FileNames.Count - 1 to 1 Step -1 ' Check my counting here - stop at 1, 2 or 0?
Dim st1 As String = FileNames(j)
Dim st2 As String = FileNames(j - 1)
If st1 = st2 Then
FileNames.RemoveAt(j)
FileDates.RemoveAt(j)
End If
Next j
I am writing a code to color user's input to a written questions. I am fairly new to vba, the code is working fine but I want to improve it, that is detect errors and incase something goes wrong with the code the documents still functions normally.
I have two types of input, either the user select something from dropdown menu or write his/her own answer (usually numbers, so I have a function to trim the answer for numbers incase there was character).
example:
Q:Number of work hours?
A: Five (5) ----> the code check the value (5) and based on it the "Five (5)" color changes to green.
I appreciate your help.
Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As
Boolean, Cancel As Boolean)
Dim store As String
Dim storeNum As Integer
If ActiveDocument.Bookmarks.Exists("high") = True Then
store = ActiveDocument.Bookmarks("high").Range.Text
If store = "0" Then
ActiveDocument.Bookmarks("high").Range.Font.TextColor = RGB(103, 106, 110)
Else
ActiveDocument.Bookmarks("high").Range.Font.TextColor = vbRed
End If
End If
If ActiveDocument.Bookmarks.Exists("medium") = True Then
End If
If (ActiveDocument.Bookmarks.Exists("bidders") = True) And (ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids received and alternatives") Then
storeNum = ExtractNumber(ActiveDocument.Bookmarks("bidders").Range)
If storeNum > 7 Then
ActiveDocument.Bookmarks("bidders").Range.Font.TextColor = RGB(0, 176, 80)
ElseIf (storeNum > 3) And (storeNum < 8) Then
ActiveDocument.Bookmarks("bidders").Range.Font.ColorIndex = wdDarkYellow
ElseIf storeNum < 4 Then
ActiveDocument.Bookmarks("bidders").Range.Font.TextColor = vbRed
End If
End If
For Each oContentControl In ActiveDocument.ContentControls
If oContentControl.Type = wdContentControlRichText Then
oContentControl.Range.Font.Color = RGB(103, 106, 110)
oContentControl.Range.Font.Name = "Trebuchet MS"
oContentControl.Range.Font.Size = 11
oContentControl.Application.ActiveDocument.Paragraphs.Alignment = wdAlignParagraphJustify
End If
Next
ActiveDocument.Fields.Update
End Sub
Function ExtractNumber(rCell As Range)
Dim iCount As Integer, i As Integer
Dim sText As String
Dim lNum As String
sText = rCell
For iCount = Len(sText) To 1 Step -1
If IsNumeric(Mid(sText, iCount, 1)) Then
i = i + 1
lNum = Mid(sText, iCount, 1) & lNum
End If
If i = 1 Then lNum = CInt(Mid(lNum, 1, 1))
Next iCount
ExtractNumber = CLng(lNum)
End Function
Well... it is a broad question but there a few problems nonetheless:
If (ActiveDocument.Bookmarks.Exists("bidders") = True) And ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids
received and alternatives") Then
Because both parts of the And are evaluated. In other words, even if the bookmark "bidders" does not exist you are still asking for the text, which generates an error.
A better way would be to use a nested If:
If (ActiveDocument.Bookmarks.Exists("bidders") = True) Then
If ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids received and alternatives") Then
' Your Code
End If
End If
Also this If block is empty (best to delete it):
If ActiveDocument.Bookmarks.Exists("medium") = True Then
End If
You may also run into trouble with the content controls, sometimes they can be locked for editing in which case you may expect an error when you try to set the font .name, .color, .size.
You can test and set whether or not a content control is locked with this:
If activedocument.ContentControls(1).LockContents = True Then ' Prevent edit
If activedocument.ContentControls(1).LockContentControl = True Then ' Prevent delete
' Note you don't actually need the " = True", it is just there for clarity
I have some code I have used to color excel charts with for quite a few years and it has worked well, (although there are likely better ways to do it). The charts contain 2 series, the first series with a value and the second with a goal. The goal does not get colored but the vba loops through the first series and colors according to hard coded goals in the vba.
The problem I have now is that I have added a chart that has a goal that can change month to month so having the hard coding doesn't work. How can I use the same theory but compare series 1 data directly to series 2 data to determine the color, (Case Is series 1 point > series 2 point, etc). I have tried a number of ways without success so any assistance would be greatly appreciated. below is the code for the proven technique.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
V = cht.Chart.SeriesCollection(1).Values
For Each p In cht.Chart.SeriesCollection(1).Points
Counter = Counter + 1
Select Case V(Counter)
'Case Is = 1
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
Case Is < 0.98
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Case Is < 0.98
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
Case Is <= 1
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
Next
End Sub
Did you try something like:
Case Is > .SeriesCollection(2).Values()(Counter)
Also revised to get rid of some apparent redundancy (if need a loop and a counter variable, e.g., when looping several collections/arrays in parallel), it seems better IMO to just loop by index, rather than For Each _object_ with a separate counter.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = .SeriesCollection(1).Values
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
Case Is > .SeriesCollection(2).Values()(Counter)
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
And unless you need the values in an array V for some other reason, this can be further reduced:
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim val1, val2
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
' extract specific point value to variables:
val1 = .SeriesCollection(1).Values()(Counter)
val2 = .SeriesCollection(2).Values()(Counter)
Select Case V(Counter)
Case val1 > val2
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
Edited with final code, The gradient needed 2 refreshes to completely fill in, (I would have to hit another tab and then go back), so I added a loop to run the code through twice and now it updates perfect the first time. Hopefully this helps others. This allows for a completely dynamic chart. Again, thank you David.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
Dim L As Integer
For L = 1 To 2
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = cht.Chart.SeriesCollection(1).Values
For Counter = 1 To .SeriesCollection(1).Points.Count
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
'Blue Gradient
'Case Is = .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
'Red Gradient
Case Is < .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Yellow Gradient
'Case Is < .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
'Green Gradient
Case Is >= .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
End With
Next
Next L
End Sub
I am attempting to write functiona that will give you the closest city from a list to a given coordinate or the state depending on a boolean value. here is what I have
Function GetCity(x As String, Optional b as Boolean) As String
Dim i As Long, count As Long, row As Long
Dim min As Double
Count = Range("Table_IVO").Rows.Count
min = 9999999
For i = 1 To Count
If dist(x, Range("Table_IVO")(i,1).Value) < min Then
min = dist(x, Range("Table_IVO")(i,1).Value)
row = i
End If
Next i
If b = True Then
GetCity = Range("Table_IVO")(row, 3).Value
Else
GetCity = Range("Table_IVO")(row, 2).Value
End If
End Function
The table is set as so
A B C
Coords City State
It gets in the loop but never loops? It dies before even executing the if
If b = True Then
GetCity = Range("Table_IVO")(row, 3).Value
Else
GetCity = Range("Table_IVO")(row, 2).Value
End
Though I might get more clarity by looking at complete code, but if this is exactly your code which u are executing, then probably you missed writing If at the end of End in the last line of your code sample, as in
If b = True Then
GetCity = Range("Table_IVO")(row, 3).Value
Else
GetCity = Range("Table_IVO")(row, 2).Value
End If
Depending on the environment you are executing your code, it may not show a compilation error.
Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.