I have a userform with 6 list objects. All of the list objects have named range rowsources. Clicking any one item in any one list will reference a chart on a spreadsheet and clear contents of any item's cell that does not belong with what was selected (explained better at the bottom of this, if you're interested). All of my list objects only have "After Update" triggers, everything else is handled by private subs.
Anyway, there's a lot of looping and jumping from list to list. If I run the userform normally, it endlessly loops. It seems to run through once, and then acts as though the user has again clicked the same item in the list, over and over again.
The odd thing is, if I step through the code (F8), it ends perfectly, when it's supposed to and control is returned to the user.
Does anyone have any thoughts on why that might be?
EDIT: I didn't originally post the code because all of it is basically a loop, and there's 150+ lines of it. I don't understand how it can be the code if stepping through makes it work perfectly, but allowing it to run regular makes it endless loop. Anyway, here's the code:
Option Explicit
Dim arySelected(6) As String
Dim intHoldCol As Integer, intHoldRow As Integer
Dim strHold As String
Dim rngStyleFind As Range, rngStyleList As Range
Private Sub UserForm_Activate()
Set rngStyleList = Range("Lists_W_Style")
Set rngStyleFind = Range("CABI_FindStyle")
End Sub
Private Sub lstStyle_AfterUpdate()
If lstStyle.ListIndex >= 0 Then
arySelected(0) = lstStyle.Value
Call FilterCabinetOptions(Range("Lists_W_Style"), Range("CABI_FindStyle"), 0)
End If
End Sub
Private Sub lstWood_AfterUpdate()
If lstWood.ListIndex >= 0 Then
arySelected(1) = lstWood.Value
Call FilterCabinetOptions(Range("Lists_W_Wood"), Range("CABI_FindWood"), 1)
' lstWood.RowSource = "Lists_W_Wood"
End If
End Sub
Private Sub cmdReset_Click()
Range("Lists_S_Style").Copy Destination:=Range("Lists_W_Style")
Call RemoveXes(Range("Lists_W_Style"))
Range("Lists_S_Wood").Copy Destination:=Range("Lists_W_Wood")
Call RemoveXes(Range("Lists_W_Wood"))
Range("Lists_S_Door").Copy Destination:=Range("Lists_W_Door")
Call RemoveXes(Range("Lists_W_Door"))
Range("Lists_S_Color").Copy Destination:=Range("Lists_W_Color")
Call RemoveXes(Range("Lists_W_Color"))
Range("Lists_S_Glaze").Copy Destination:=Range("Lists_W_Glaze")
Call RemoveXes(Range("Lists_W_Glaze"))
Range("Lists_S_Const").Copy Destination:=Range("Lists_W_Const")
Call RemoveXes(Range("Lists_W_Const"))
Range("Lists_S_DrawFrontConst").Copy Destination:=Range("Lists_W_DrawFrontConst")
Call RemoveXes(Range("Lists_W_DrawFrontConst"))
End Sub
Private Sub FilterCabinetOptions(rngList As Range, rngFind As Range, intAry As Integer)
Dim intListCntr As Integer, intFindCntr As Integer, intStyleCntr As Integer
If intAry = 0 Then
Call FindStyle(arySelected(intAry))
Else
'Save the List item.
For intListCntr = 1 To rngList.Rows.Count
If rngList.Cells(intListCntr, 1) = arySelected(intAry) Then
rngList.Cells(intListCntr, 3) = "X"
' Call RemoveNonXes(rngList)
Exit For
End If
Next intListCntr
'Save the column of the Find List.
For intFindCntr = 1 To rngFind.Columns.Count
If rngFind.Cells(1, intFindCntr) = arySelected(intAry) Then
'Minus 2 to allow for columns A and B when using Offset in the below loop.
intHoldCol = rngFind.Cells(1, intFindCntr).Column - 2
Exit For
End If
Next intFindCntr
'Find appliciple styles.
For intStyleCntr = 1 To rngStyleFind.Rows.Count
If Len(rngStyleFind.Cells(intStyleCntr, intHoldCol)) > 0 Then
Call FindStyle(rngStyleFind.Cells(intStyleCntr, 1))
End If
Next intStyleCntr
End If
Call RemoveNonXes(rngStyleList)
Call RemoveNonXes(Range("Lists_W_Wood"))
Call RemoveNonXes(Range("Lists_W_Door"))
Call RemoveNonXes(Range("Lists_W_Color"))
Call RemoveNonXes(Range("Lists_W_Glaze"))
Call RemoveNonXes(Range("Lists_W_Const"))
Call RemoveNonXes(Range("Lists_W_DrawFrontConst"))
End Sub
Private Sub FindStyle(strFindCode As String)
Dim intListCntr As Integer, intFindCntr As Integer
For intListCntr = 1 To rngStyleList.Rows.Count
If rngStyleList.Cells(intListCntr, 1) = strFindCode Then
rngStyleList.Range("C" & intListCntr) = "X"
Exit For
End If
Next intListCntr
For intFindCntr = 1 To rngStyleFind.Rows.Count
If rngStyleFind.Cells(intFindCntr, 1) = strFindCode Then
intHoldRow = rngStyleFind.Cells(intFindCntr).Row
Exit For
End If
Next intFindCntr
If Len(arySelected(1)) = 0 Then Call FindStyleOptions(Range("CABI_FindWood"), Range("Lists_W_Wood"))
If Len(arySelected(2)) = 0 Then Call FindStyleOptions(Range("CABI_FindDoor"), Range("Lists_W_Door"))
If Len(arySelected(3)) = 0 Then Call FindStyleOptions(Range("CABI_FindColor"), Range("Lists_W_Color"), Range("Lists_W_Wood"))
If Len(arySelected(4)) = 0 Then Call FindStyleOptions(Range("CABI_FindGlaze"), Range("Lists_W_Glaze"), Range("Lists_W_Wood"))
If Len(arySelected(5)) = 0 Then Call FindStyleOptions(Range("CABI_FindConst"), Range("Lists_W_Const"))
If Len(arySelected(6)) = 0 Then Call FindStyleOptions(Range("CABI_FindDrawFrontConst"), Range("Lists_W_DrawFrontConst"))
End Sub
Private Sub FindStyleOptions(rngFind As Range, rngList As Range, Optional rngCheckList As Range)
Dim intListCntr As Integer, intFindCntr As Integer
Dim intStrFinder As Integer, intCheckCntr As Integer
Dim strHoldCheck As String
Dim strHoldFound As String, strHoldOption As String
'Go through the appropriate find list (across the top of CABI)
For intFindCntr = 1 To rngFind.Columns.Count
strHoldOption = rngFind.Cells(1, intFindCntr)
strHoldFound = rngFind.Cells(1, intFindCntr).Offset((intHoldRow - 1), 0)
If Len(strHoldFound) > 0 Then
If rngCheckList Is Nothing Then
For intListCntr = 1 To rngList.Rows.Count
If rngList.Cells(intListCntr, 1) = strHoldFound Then
Call AddXes(rngList, strHoldFound, "X")
Exit For
End If
Next intListCntr
Else
intStrFinder = 1
Do While intStrFinder < Len(rngFind.Cells(1, intFindCntr).Offset((intHoldRow - 1), 0))
strHoldCheck = Mid(rngFind.Cells(1, intFindCntr).Offset((intHoldRow - 1), 0), intStrFinder, 2)
intStrFinder = intStrFinder + 3
For intCheckCntr = 1 To rngCheckList.Rows.Count
If strHoldCheck = rngCheckList(intCheckCntr, 1) And Len(rngCheckList(intCheckCntr, 3)) > 0 Then
Call AddXes(rngList, strHoldOption, "X")
intStrFinder = 99
Exit For
End If
Next intCheckCntr
Loop
End If
End If
Next intFindCntr
End Sub
Private Sub AddXes(rngList As Range, strToFind As String, strX As String)
Dim intXcntr As Integer
For intXcntr = 1 To rngList.Rows.Count
If rngList.Cells(intXcntr, 1) = strToFind Then
rngList.Cells(intXcntr, 3) = strX
Exit For
End If
Next intXcntr
End Sub
Private Sub RemoveNonXes(rngList As Range)
Dim intXcntr As Integer
For intXcntr = 1 To rngList.Rows.Count
If Len(rngList(intXcntr, 3)) = 0 Then
rngList.Range("A" & intXcntr & ":B" & intXcntr) = ""
Else
rngList.Range("C" & intXcntr) = ""
End If
Next intXcntr
End Sub
Private Sub RemoveXes(rngList As Range)
rngList.Range("C1:C" & rngList.Rows.Count) = ""
End Sub
Explanation:
Imagine you had 6 lists with different automobile conditions. So Make would be one list with Chevy, Ford, Honda... Model would be another with Malibu, Focus, Civic... But you'd also have Color Blue, Red, Green... So if your user wants a Green car, the program references an inventory list and gets rid of any Makes, Models, etc... not available in green. Likewise the user could click on Civic from the Model list and it would elminate all but Honda from the Make and so on. That's what I'm trying to do anyway.
Without seeing the code it's tough to tell. When you run the script, the 'AfterUpdate' event may be getting triggered over and over, causing the endless loop. Try using a counter to limit the update to one change and have it exit the loop once the counter is greater than 0.
Related
As you see in the above image, I have 2 ComboBoxes: "Select Dimension" and "List of possible values".
There are different dimensions the user can select and for each dimension there's a list of possible values. My code is partially working well. When I select a dimension for the 1st time the list of possible values appears properly.
Problem: When I select a different dimension, the list of possible values from the previous dimension still appears, instead of the values for the new selected dimension.
Question: Is there a way to solve this issue? So that when I switch between dimensions the lists of possible values also update.
#1: Function that gets the values from the Worksheet and adds them to the "List of possible values" combobox.
Public Function DimValuesSearch(strSearch As String)
Call loadWbVariables
Dim selectedDimension As String, possibleValue As String
Dim countValues As Long
Dim DimCell As Range
selectedDimension = frmSeg.seg_cbb_selDim.Value
Set DimCell = dtValWs.Rows(1).Find(What:=strSearch)
If selectedDimension = strSearch Then
countValues = 0
While dtValWs.Cells(4 + countValues, DimCell.Column) <> ""
possibleValue = dtValWs.Cells(4 + countValues, DimCell.Column)
frmSeg.seg_cbb_posVal.AddItem possibleValue
countValues = countValues + 1
Wend
End If
End Function
#2: I call the function using the different dimensions name. seg_cbb_selDim is the Dimension ComboBox.
Public Sub seg_cbb_selDim_Change()
' Functions that calls text dimensions
' Insert remaining dimensions
Call DimValuesSearch("Specialty Grouping")
Call DimValuesSearch("Primary Specialty")
End Sub
It was more simple than I though, I had to do a small change in the function above. Here's the new function:
Public Function DimValuesSearch(strSearch As String)
Call loadWbVariables
Dim selectedDimension As String, possibleValue As String
Dim countValues As Long
Dim DimCell As Range
selectedDimension = frmSeg.seg_cbb_selDim.Value
Set DimCell = dtValWs.Rows(1).Find(What:=strSearch)
If selectedDimension = strSearch Then
countValues = 0
frmSeg.seg_cbb_posVal.Clear 'Added this line here
While dtValWs.Cells(4 + countValues, DimCell.Column) <> ""
possibleValue = dtValWs.Cells(4 + countValues, DimCell.Column)
frmSeg.seg_cbb_posVal.AddItem possibleValue
countValues = countValues + 1
Wend
End If
End Function
You need to use the Change event of your Dimension box to remove all items in the other combo and reload it with the desired items.
It would look something like this:
Private Sub ComboBoxDimensions_Change()
Me.ComboBox2.Clear
LoadValuesIntoComboBox2
Me.ComboBox3.Clear
LoadValuesIntoComboBox3
End Sub
Public Sub LoadValuesIntoComboBox2()
'your code to reload the desired data ino ComboBox2
End Sub
Public Sub LoadValuesIntoComboBox3()
'your code to reload the desired data ino ComboBox3
End Sub
I've got an UserForm, which upon an incorrect user input calls the following procedure, which highlights the field and disables the "save changes" button.
Private disabledElems As New Collection
Private Sub disable(ByRef controlName As String)
UserForm1.Controls(controlName).BackColor = &H8080FF
Me.save_button.Enabled = False
Dim i As Byte
If disabledElems.Count <> 0 Then
For i = 1 To disabledElems.Count
If disabledElems(i) = controlName Then
Exit Sub ' we dont want to add duplicates to collection
End If
Next i
End If
disabledElems.Add controlName ' otherwise add to collection
End Sub
If the input is corrected, it calls the enable procedure, which looks like this:
Private Sub enable(ByRef controlName As String)
Me.Controls(controlName).BackColor = &H80000005
Dim i As Byte
For i = 1 To disabledElems.Count
If disabledElems(i) = controlName Then
disabledElems.Remove i ' remove the enabled element upon match
End If
Next i
If disabledElems.Count = 0 Then
save_button.Enabled = True
End If
End Sub
This seems to work just fine when I try this with one Textbox
However, as soon I have multiple incorrect entries, my enable procedure seems to throw a Subscript out of range error seemingly for no reason.
The highlighted line in the debugger is:
If disabledElems(i) = controlName Then
I can't comprehend what could be causing this. Any ideas?
Ah alright, it's one of those classical "when removing a row, loop
from end to beginning"
Basically, the reason why the Subscript out of range was thrown - once the element was removed from the collection via the
disabledElems.Remove i
It reduced the size of the Collection from Collection.Count to Collection.Count - 1, however during the for loop declaration, the i was already hard-set to the previous Collection.Count
In an practical example:
Let's say my Collection looks like this
disabledElems = "button1", "button2"
Upon doing this
controlName = "button1"
For i = 1 to disabledElems.Count ' <= 2
If disabledElems(i) = controlName ' < True for i = 1
disabledElems.Remove i ' < button1 was removed from collection, however it still loops
End If
' will loop to i = 2. However disabledElems(2) no longer exists, because upon removal _
the button2 was shifted to disabledElems(1) - hence Subscript out of range
Next i
A clear case of trying to access an element, which has shifted its position in the queue.
There are two possible fixes (that I can think of):
1. Enforce Exit Sub upon removal
For i = 1 to disabledElems.Count
If disabledElems(i) = controlName
disabledElems.Remove i
Exit Sub
End If
Next i
2. Loop from end to start
Dim i as Integer ' needs to be redeclared to int, because Byte can't -1
For i = disabledElems.Count to 1 Step -1
If disabledElems(i) = controlName
disabledElems.Remove i
End If
Next i
Public Sub addtoMA(dbPrice As Double, dbRow As Double, sh As Worksheet)
Dim s As Long 'for bitshifting the array
Const colstosave = 50
Dim rn As Range, intPrice() As Variant
deActsheet 'stop events and other annoyance
On Error GoTo catch
If dbRow = 0 Then
'MsgBox "row number missing in addtoma"
GoTo finally
End If
Set rn = sh.Range("At" & dbRow & ":cQ" & dbRow) 'the row
intPrice() = rn 'the array
' shift elements one position right- e.g. arr 99 moves to arr 100
For s = colstosave To 2 Step -1
If intPrice(1, s - 1) <> "" Then
intPrice(1, s) = intPrice(1, s - 1)
Else
intPrice(1, s) = 0
End If
Next s
intPrice(1, 1) = dbPrice 'current price
rn = intPrice() 'store the array
finally:
Set rn = Nothing
actSheet 'allow events and other annoyance
Exit Sub
catch:
'MsgBox Err.Description
Debug.Print ""
GoTo finally
End Sub
The code above runs perfectly when I call form the immediate window with:
addtoMA 5,9,sheetpointer
in integration it is called by a function that is embedded as a formula.
The parameters the are receibed are identical I double checked this.
rn.rows and rn.columns.count are exactly the same dimensions as
ubound(intprice,1) and ubound(intprice,2)
Yet every time it is called from the sheet it fails with
Application-defined or object-defined error
I could just use a database, but I cant be beaten by this.
Any ideas?
It just generates a few moving averages for a bot
I'm new to vba script. I am trying to write a function below but couldn't make it out successfully. I really appreciate any help I can get on this.
The code is:
Option Explicit
Dim status As String
Sub StartModule()
Dim index As Integer
Dim result As String
Dim a As Integer
Dim Name As Variant
Range("D4").Value = 1
Range("D5").Value = 5
Range("D6").Value = 9
Range("D7").Value = 2
Dim o: Set o = CreateObject("NAddIn.Functions")
status = ""
Do Until status = "DADA"
result = o.getRandomNumber
Name = Split(result, ",")
If Trim(Name(3)) = Trim(Range("D4").Value) Then
Range("C4").Value = "one"
End If
If Trim(Name(3)) = Trim(Range("D5").Value) Then
Range("C5").Value = "five"
End If
If Trim(Name(3)) = Trim(Range("D6").Value) Then
Range("C4").Value = "nine"
End If
If Trim(Name(3)) = Trim(Range("D7").Value) Then
Range("C7").Value = "two"
End If
Wait 1 '<~~ Wait for a second
If status = "EXIT" Then Exit Do
Loop
End Sub
Sub StopModule()
status = "EXIT"
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
This vba script is calling a getRandomNumber() which is a user defined function in dll file. It generates string of random numbers in the range(1,10); Then the thrid random number in the string is compared with cell values in excel to update cells in excel with some string values.
Bu,the problem is I am getting an error Run-time error 9: Subscript out of range at line If Trim(Name(3)) = Trim(Range("D4").Value) then.
Then the thrid random number in the string is compared with cell
values in excel to update cells in excel with some string values.
You're comparing fourth random number. Your 'Name' elements are (0),(1),(2),(3),(4),...
I suppose there is no element Name(3) as you're getting 'out of range' error.
A listbox is passed, the data placed in an array, the array is sort and then the data is placed back in the listbox. The part that does work is putting the data back in the listbox. Its like the listbox is being passed by value instead of by ref.
Here's the sub that does the sort and the line of code that calls the sort sub.
Private Sub SortListBox(ByRef LB As MSForms.ListBox)
Dim First As Integer
Dim Last As Integer
Dim NumItems As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
Dim TempArray() As Variant
ReDim TempArray(LB.ListCount)
First = LBound(TempArray) ' this works correctly
Last = UBound(TempArray) - 1 ' this works correctly
For i = First To Last
TempArray(i) = LB.List(i) ' this works correctly
Next i
For i = First To Last
For j = i + 1 To Last
If TempArray(i) > TempArray(j) Then
Temp = TempArray(j)
TempArray(j) = TempArray(i)
TempArray(i) = Temp
End If
Next j
Next i ! data is now sorted
LB.Clear ! this doesn't clear the items in the listbox
For i = First To Last
LB.AddItem TempArray(i) ! this doesn't work either
Next i
End Sub
Private Sub InitializeForm()
' There's code here to put data in the list box
Call SortListBox(FieldSelect.CompleteList)
End Sub
Thanks for your help.
This works for me on Excel 2003 on a very basic UserForm with a single ListBox called ListBox1:
Private Sub UserForm_Initialize()
ListBox1.AddItem "john"
ListBox1.AddItem "paul"
ListBox1.AddItem "george"
ListBox1.AddItem "ringo"
SortListBox ListBox1
End Sub
and then your SortListBox as written apart from fixing the three comments which start with ! rather than '
The only difference to your initializer is the name (UserForm_Initialize vs InitializeForm). Make sure to use the object and event selectors at the top of the code page for the userform to ensure that the event handlers get named correctly
You can't pass objects by value. Since you're not going to return another instance of listbox to the caller, you should declare LP as ByVal. That does not affect the code though. It works and the list gets sorted. I think you omitted some importand details.
Here is how I used this, for example, w/ a relational Dictionary and two columns:
Private Sub UserForm_Initialize()
Call HideTitleBar(Me)
Set ExtraFiltersDic = CreateObject("scripting.dictionary")
ExtraFiltersDic.CompareMode = 1
Set ExtraFiltersDic = GetExtraFiltersDic()
Dim k
For Each k In ExtraFiltersDic.Keys
ListBox1.AddItem k
Next
Call SortListBox(ListBox1, ListBox2, ExtraFiltersDic)
End Sub
Public Sub SortListBox(ByRef ListBox As MSForms.ListBox, Optional ByRef ListBox2 As MSForms.ListBox, Optional ByRef RelationalDic As Object)
Dim First As Integer, Last As Integer, NumItems As Integer
Dim i As Integer, j As Integer
Dim TempArray() As Variant, Temp As String
ReDim TempArray(ListBox.ListCount)
First = LBound(TempArray)
Last = UBound(TempArray) - 1
For i = First To Last
TempArray(i) = ListBox.List(i)
Next i
For i = First To Last
For j = i + 1 To Last
If TempArray(i) > TempArray(j) Then
Temp = TempArray(j)
TempArray(j) = TempArray(i)
TempArray(i) = Temp
End If
Next j
Next i
ListBox.Clear
If Not ListBox2 Is Nothing And Not RelationalDic Is Nothing Then
Set KeyValDic = CreateObject("scripting.dictionary")
Set KeyValDic = RelationalDic
End If
For i = First To Last
ListBox.AddItem TempArray(i)
If Not ListBox2 Is Nothing And Not RelationalDic Is Nothing Then
ListBox2.AddItem KeyValDic(TempArray(i))
End If
Next i
End Sub
I dont know if this would work for you but try it this way.
First, make an array of all the items in the list box
Pass that array to your function
Sort that array
return the array to the main program
clear the listbox
overwrite the listbox items with the new array