What I am trying to achieve is Cascading or Dependent ComboBoxes and with help I have finally had success with all 4.
ComboBox1 = Category
ComboBox2 = Sub Category
ComboBox3 = Location (unique to chosen subcategory)
ComboBox4 = Customer (unique to chosen subcategory and location)
What is occurring is in comboBox4 all of the customers for the selected Location are populating combobox4 instead of all of the customers for the selected location that also coincide with the subcategory.
ComboBox1 = cmbRent
ComboBox2 = cmbSub
ComboBox3 = cmbLoc
ComboBox4 = cmbCust
All of my codes which are located on the worksheet "CHART".
All of my data is located on the worksheet "DATA"
All of my ComboBoxes are located "CHART"
The data that is being referenced is in 4 columns in the order that the boxes are.
Column1 = Category
Column2 = Sub Category
Column3 = Location
Column4 = Customer
I feel like I need to be referenceing the Selection in cmbSub and cmbLoc in order to achieve what I want?
Here are all of my combobox codes that are applied to the worksheet
Private Sub cmbRent_Change()
Dim wsChart As Worksheet
Dim wsData As Worksheet
Dim listOfValues As String 'To store list of values already added
Dim ValueToAdd As String 'To store new value to add
listOfValues = ""
Set wsChart = ThisWorkbook.Sheets("CHART")
Set wsData = ThisWorkbook.Sheets("DATA")
MyVal = Me.cmbRent.Value
'loop thru col B
lr = ThisWorkbook.Sheets("DATA").Cells(Rows.Count, 1).End(xlUp).Row
'clear cmbSub
ThisWorkbook.Sheets("CHART").cmbSub.Clear
For x = 2 To lr
If MyVal = wsData.Cells(x, 1) Then
'add to combobox
ValueToAdd = wsData.Cells(x, 2) 'Get value from worksheet
If InStr(listOfValues, wsData.Cells(x, 2)) = 0 Then
'Check to see if the value has already been added
'If not, add to values added and add the item to the combobox.
listOfValues = listOfValues & ValueToAdd
Me.cmbSub.AddItem ValueToAdd
End If
End If
Next x
ThisWorkbook.Sheets("CHART").cmbSub.ListIndex = -1
End Sub
Private Sub cmbSub_Change()
Dim wsChart As Worksheet
Dim wsData As Worksheet
Dim listOfValues As String 'To store list of values already added
Dim ValueToAdd As String 'To store new value to add
listOfValues = ""
Set wsChart = ThisWorkbook.Sheets("CHART")
Set wsData = ThisWorkbook.Sheets("DATA")
MyVal = ThisWorkbook.Sheets("CHART").cmbSub.Value
'loop thru col c
lr = wsData.Cells(Rows.Count, 2).End(xlUp).Row
ThisWorkbook.Sheets("CHART").cmbLoc.Clear
For x = 2 To lr
If MyVal = wsData.Cells(x, 2) Then
'add to combobox
ValueToAdd = wsData.Cells(x, 3) 'Get value from worksheet
If InStr(listOfValues, wsData.Cells(x, 3)) = 0 Then
'Check to see if the value has already been added
'If not, add to values added and add the item to the combobox.
listOfValues = listOfValues & ValueToAdd
ThisWorkbook.Sheets("CHART").cmbLoc.AddItem ValueToAdd
End If
End If
Next x
ThisWorkbook.Sheets("CHART").cmbLoc.ListIndex = -1
End Sub
Private Sub cmbLoc_Change()
Dim wsChart As Worksheet
Dim wsData As Worksheet
Dim listOfValues As String 'To store list of values already added
Dim ValueToAdd As String 'To store new value to add
listOfValues = ""
Set wsChart = ThisWorkbook.Sheets("CHART")
Set wsData = ThisWorkbook.Sheets("DATA")
MyVal = ThisWorkbook.Sheets("CHART").cmbLoc.Value
'loop thru col D
lr = wsData.Cells(Rows.Count, 3).End(xlUp).Row
ThisWorkbook.Sheets("CHART").cmbCust.Clear
For x = 2 To lr
If MyVal = wsData.Cells(x, 3) Then
'add to combobox
ValueToAdd = wsData.Cells(x, 4) 'Get value from worksheet
If InStr(listOfValues, wsData.Cells(x, 4)) = 0 Then
'Check to see if the value has already been added
'If not, add to values added and add the item to the combobox.
listOfValues = listOfValues & ValueToAdd
ThisWorkbook.Sheets("CHART").cmbCust.AddItem ValueToAdd
End If
End If
Next x
ThisWorkbook.Sheets("CHART").cmbCust.ListIndex = -1
End Sub
If you would like some more background, please view this link: Excel '13 VBA Cascading ComboBox - Trouble getting unique values in Combobox2
The problem is that you aren't doing a comparison for the subcategory in your code.
A bigger issue that you are having is that you don't seem to understand what the code is doing. I would take some time to walk through your code and try to understand what every line is doing. Possibly watch the video that you referenced in one of your other posts again.
The part of your code that is checking which values to put into combobox4, aka cmbCust is here:
If MyVal = wsData.Cells(x, 3) Then
This is checking MyVal, which has previously been defined as:
MyVal = ThisWorkbook.Sheets("CHART").cmbLoc.Value
This is only the selection in the cmbLoc, which corresponds to the location, but doesn't include the subcategory.
You need to do two checks, and I'd fix the variable names so that they are more clear.
Dim LocVal As String
Dim SubCatVal As String
....more code here
LocVal = ThisWorkbook.Sheets("CHART").cmbLoc.Value
SubCatVal = ThisWorkbook.Sheets("CHART").cmbSub.Value
....more code here
'Now do the comparison
If LocVal = wsData.Cells(x, 3) And SubCatVal = wsData.Cells(x,2) Then
ValueToAdd = wsData.Cells(x, 4)
.....Rest of code in the if statement
Related
I have an automatically generated listbox with checkboxes. I now want this listbox to check if certain values appear in a range and select these on the listbox.
How do I do this?
I have the following code set up to generate the listbox with values:
Private Sub UserForm_Initialize()
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Dim curColumn As Long
Dim LastRow As Long
curColumn = 1
LastRow = Worksheets("Hidden_Classes").Cells(Rows.Count, curColumn).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("Hidden_Classes").Range("A2:A" & LastRow)
'Fill the listbox
Set lbtarget = Me.lstCheckBoxes
With lbtarget
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
'Insert the range of data supplied
.List = rngSource.Value
End With
End Sub
The items I need to be selected on the listbox appear on the folowing Range:
Worksheets("Hidden_Classes").Range("P2:P15")
As i mentioned in the comment to the question, you have to loop through the items in a ListBox and the values in the column P.
Dim wsh As Worksheet
Dim SecondLastRow As Integer, i As Integer, j As Integer
Set wsh = Worksheets("Hidden_Classes")
'change your code here to use [wsh] variable instead of [Worksheets("Hidden_Classes")]
'add below lines right after [End With]
SecondLastRow = wsh.Range("P" & wsh.Rows.Count).End(xlUp).Row
For i = 0 To lbtarget.ListCount -1
For j = 2 To SecondLastRow
If wsh.Range("A" & i+2) = wsh.Range("P" & j) Then
lbtarget.Selected(i) = True
Exit For 'value has been found and selected, you can skip second [for] loop
End If
Next j
Next i
Should be easy, try:
For i=2 to LastRow
'Customize your condition for adding them to the listbox or just skip the IF if you want to add them all
If Worksheets("Hidden_Classes").Cells(i,"A") = "Condition" Then
lbtarget.AddItem Worksheets("Hidden_Classes").Cells(i,"A")
End If
Next i
I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub
I am trying to create a Dropdown menu in Excel using VBA. When you select an item on the Dropdown menu, it should take a named range in the Workbook and insert it in a range below. I want to do this so I can compare various ranges.
I am unsure how to tackle this, this is what I've tried so far:
Function Compare()
Dim variable1 As String
Dim variable2 As String
Dim dd1 As DropDown
Dim dd2 As DropDown
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Compare")
Set dd1 = ActiveSheet.DropDowns("dropdown1")
Set dd2 = ActiveSheet.DropDowns("dropdown2")
Set r1 = ws.Range(dd1.ListFillRange)
Set r2 = ws.Range(dd2.ListFillRange)
Set variable1 = r1(dd1.Value)
Set variable2 = r2(dd2.Value)
If variable1 = "Example 1" Then
wb.ws.Range("h12:j58").Value = Range("ap_ks")
End If
End Function
I've managed to do it with an IF statement, but only for 1 of the items so far. Doing it for all items would make the formula very large, so instead I am trying to do it in VBA.
{=IFS(D8=Overview!C8;IF(AP_KS=0;"";AP_KS);0=1;)}
The following copies a selected range from one sheet (given a sequence of columns) onto a selected column in another, skipping the headers. It works with a couple activex comboboxes for selecting the columns rather than dropdowns and named range.
The column subset is partly dynamic, based on the existence of headers & some constants; updates whenever switching sheets (adding to workbook open is a good idea, and selection change is an overkill in my opinion).
Private Sub ComboBox1_Change()
Copypasta
End Sub
Private Sub ComboBox2_Change()
Copypasta
End Sub
Private Sub Worksheet_Activate()
' Both sheets.
Update_Combox
End Sub
' I've put the following code in a separate module for accessibility.
Const CFIRSTCOL = 6
Const CLASTCOL = -1
Const CSHEET = "Sheet1"
Const PFIRSTCOL = 1
Const PLASTCOL = -1 ' 3
Const PDEFCOL = 1 ' This is 0 indexed.
Const PSHEET = "Sheet2"
Sub Update_Combox()
' Populates the column selection lists.
Dim indstop As Boolean
Dim i As Integer
Dim ctrlsht
Dim csht
Set csht = Sheets(CSHEET)
Set ctrlsht = Sheets(CSHEET)
ctrlsht.ComboBox1.Clear
indstop = False
i = CFIRSTCOL
While Not indstop
If i > CLASTCOL And CLASTCOL <> -1 Then
indstop = True
ElseIf csht.Cells(1, i) = "" Then
indstop = True
Else
ctrlsht.ComboBox1.AddItem csht.Cells(1, i)
End If
i = i + 1
Wend
Set csht = Sheets(PSHEET)
ctrlsht.ComboBox2.Clear
indstop = False
i = PFIRSTCOL
While Not indstop
If i > PLASTCOL And PLASTCOL <> -1 Then
indstop = True
ElseIf csht.Cells(1, i) = "" Then
indstop = True
Else
ctrlsht.ComboBox2.AddItem csht.Cells(1, i)
End If
i = i + 1
Wend
ctrlsht.ComboBox2.ListIndex = PDEFCOL
End Sub
Sub Copypasta()
' Copypasta selected column to another sheet.
Dim copycol As Integer
Dim pastacol As Integer
Dim lastrow As Integer
Dim lastrow2 As Integer
Dim csht
Dim psht
Set csht = Sheets(CSHEET)
Set psht = Sheets(PSHEET)
If csht.ComboBox1.ListIndex <> -1 And csht.ComboBox1.ListIndex <> -1 Then
copycol = CFIRSTCOL + csht.ComboBox1.ListIndex
pastacol = PFIRSTCOL + csht.ComboBox2.ListIndex
' Need to clear the entire pasta range first.
lastrow2 = psht.Cells(Rows.Count, pastacol).End(xlUp).Row
if lastrow2 > 1 then
Range(psht.Cells(2, pastacol), psht.Cells(lastrow2, pastacol)).Clear
end if
lastrow = csht.Cells(Rows.Count, copycol).End(xlUp).Row
Range(psht.Cells(2, pastacol), psht.Cells(lastrow, pastacol)).Value = _
Range(csht.Cells(2, copycol), csht.Cells(lastrow, copycol)).Value
'psht.Activate
Else
' pass
End If
End Sub
Edit: Added some notes and small bugfix above. Including some shots below for reference.
Code
Dropbox
Other dropbox
Target sheet, empty
Copy
Pasta
I am trying to populate a ListBox with entries from multiple ListObjects.
But not all entries should be populated, only those which have a specific value in a column of the ListObject.
Example:
ListObjects consist of 3 columns: [Name], [Size], [Position]
All entries from ListObject1 to ListObject5 should be populated into the ListBox if the value in column [Position] is "Top".
Next question based on that result:
How can I then in a second ListBox display all entries of the depended ListObject where [Position] is not "Top".
In other words, not all entries which are not "Top" from all ListObjects should be displayed in the second LIstBox, only those possible entries from the specific ListObject where the value picked in the first ListBox matches.
My thoughts where maybe strange, but what about creating a whole new table (maybe an Array), which consists of all entries from all ListObjects which will be generated when opening the UserForm and then add a third column to it - [ListObjectNumber] - which consists of the information from which Table this information is coming from, that would help the second ListBox to only display the right entries... but maybe this is too far ahead.
Thank you for your help!
In a spreadsheet laid out as such:
Formatted via the Home tab with "Format as Table"; this creates ListObjects
named automatically as "Table1", "Table2", "Table3", "Table4", "Table5"
Sheet named "listbox" for example
ActiveX command button added to show the user form named frmListbox in this example:
Sub Button2_Click()
frmListbox.Show
End Sub
Private Sub cmdPopulate_Click()
Dim ws As Worksheet
Dim table As ListObject
Dim rng As Range
Dim i As Long, j As Long, criteriaRow As Long, lastCol As Long
Dim myarray() As String
With Me.lbUsed
'Set relevant sheetname (or create loop for worksheets)
Set ws = Sheets("listbox")
criteriaRow = -1
For Each table In ws.ListObjects
'Set relevant range/table
'Remember: top row are headings
Set rng = ws.Range(table)
'Remember: last colum not displayed in listbox (-1) for this example
lastCol = rng.Columns.Count - 1
.Clear
.ColumnHeads = False
.ColumnCount = lastCol
'Remember: leave out row 0; column headings
For i = 1 To rng.Rows.Count
If (rng.Cells(i, 3) = "Top") Then
criteriaRow = criteriaRow + 1
'Columns go in first demension so that rows can resize as needed
ReDim Preserve myarray(lastCol, criteriaRow)
For j = 0 To lastCol
myarray(j, criteriaRow) = rng.Cells(i, j + 1)
Next 'Column in table
End If
Next 'Row in table
Next 'Table (ListObject)
'Place array in natural order to display in listbox
.List = TransposeArray(myarray)
'Set the widths of the column, separated with a semicolon
.ColumnWidths = "100;75"
.TopIndex = 0
End With
End Sub
Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
For the 2nd question:
The code sample below shows how when clicking on an item in a list called lstDisorder populates the next list box called lstTreatment with the values from named ranges on the spreadsheet.
Private Sub lstDisorder_Click()
Dim x As Integer
x = lstDisorder.ListIndex
Select Case x
Case Is = 0
lstTreatment.RowSource = "Depression"
Case Is = 1
lstTreatment.RowSource = "Anxiety"
Case Is = 2
lstTreatment.RowSource = "OCD"
Case Is = 3
lstTreatment.RowSource = "Stubstance"
End Select
End Sub
Here is another approach:
Private Sub lstTeam_Click()
Dim colUniqueItems As New Collection
Dim vItem As Variant
Dim rFound As Range
Dim FirstAddress As String
'First listBox
Me.lstItems.Clear
'populate first listBox from range on worksheet
With Worksheets("Team").Range("A2:A" & (Cells(1000, 1).End(xlUp).row))
'Find what was clicked in first listBox
Set rFound = .Find(what:=lstTeam.Value, LookIn:=xlValues, lookat:=xlWhole)
'If something is selected, populate second listBox
If Not rFound Is Nothing Then
'Get the address of selected item in first listBox
FirstAddress = rFound.Address
On Error Resume Next
Do
'Add the value of the cell to the right of the cell selected in first listBox to the collection
colUniqueItems.Add rFound.Offset(, 1).Value, CStr(rFound.Offset(, 1).Value)
'Find the next match in the range of the first listBox
Set rFound = .FindNext(rFound)
'Keep looking through the range until there are no more matches
Loop While rFound.Address <> FirstAddress
On Error GoTo 0
'For each item found and stored in the collection
For Each vItem In colUniqueItems
'Add it to the next listBox
Me.lstItems.AddItem vItem
Next vItem
End If
End With
End Sub
Here's a good resource on listBox which shows how to populate ListBox from an Array and how to Get Selected Items from ListBox1 to ListBox2 and more.
I have a table in Excel (Table1) that has these column headings: employee name, state licensed, and license status. A sample of the table would be:
John Adams NY Active
John Adams PA Active
John Adams NJ Inactive
Ralph Ames MS Active
Ed Turner MS Pending
I want to set up a summary tab that has one row per employee with a column for active licenses, pending licenses, and inactive licenses, and those cells would display a comma-separated list of the appropriate state codes. For example:
Name Active Pending Inactive
John Adams NY, PA NJ
Ralph Ames MS
Ed Turner MS
I'm just curious about the best way to get to this custom list. I wrote the function below which seems to work fine, and it runs faster than I expected, but it just seems inefficient because it loops through the entire table every time, and I've pasted formulas referencing this function to a few hundred cells:
Function comma_state_list(the_name As String, the_status As String) As String
Dim ws As Worksheet
Dim oLo As ListObject
Dim oCol As ListColumns
Set ws = Worksheets("State Licenses")
Set oLo = ws.ListObjects("Table1")
Set oCol = oLo.ListColumns
For i = 1 To oLo.ListRows.Count
If oLo.Range(i, 1).Value = the_name And oLo.Range(i, 3) = the_status Then
comma_state_list = comma_state_list & oLo.Range(i, 4) & ", "
End If
Next i
If Len(comma_state_list) = 0 Then
comma_state_list = ""
Else
comma_state_list = Left(comma_state_list, Len(comma_state_list) - 2)
End If
End Function
Is there a way to maybe use VBA to run a SQL-like query against the table so I'm just looping through the SQL result instead of the entire table every time? I was thinking this would help to alphabetize the summary list too. Or maybe there's some other better way I'm not thinking of.
OK, so here is an example using Scripting Dictionaries.
I have this table on one worksheet:
And the output should produce a new worksheet with summary data like:
I tried to document it pretty thoroughly but let me know if you have any questions about it.
Option Explicit
Sub Test()
Dim wsCurr As Worksheet: Set wsCurr = ActiveSheet
Dim wsNew As Worksheet 'output container'
Dim rowNum As Long 'row number for output'
'Scripting dictionaries:'
Dim inactiveDict As Object
Dim activeDict As Object
Dim key As Variant
'Table variables'
Dim rng As Range 'table of data'
Dim r As Long 'row iterator for the table range.'
'information about each employee/row'
Dim empName As String
Dim state As String
Dim status As String
'Create our dictionaries:'
Set activeDict = Nothing
Set inactiveDict = Nothing
Set activeDict = CreateObject("Scripting.Dictionary")
Set inactiveDict = CreateObject("Scripting.Dictionary")
Set rng = Range("A1:C6") 'better to set this dynamically, this is just an example'
For r = 2 To rng.Rows.Count
empName = rng(r, 1).Value
state = rng(r, 2).Value
status = rng(r, 3).Value
Select Case UCase(status)
Case "ACTIVE"
AddItemToDict activeDict, empName, state
Case "INACTIVE"
AddItemToDict inactiveDict, empName, state
End Select
Next
'Add a new worksheet with summary data'
Set wsNew = Sheets.Add(After:=wsCurr)
With wsNew
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Active"
.Cells(1, 3).Value = "Inactive"
rowNum = 2
'Create the initial table with Active licenses'
For Each key In activeDict
.Cells(rowNum, 1).Value = key
.Cells(rowNum, 2).Value = activeDict(key)
rowNum = rowNum + 1
Next
'Now, go over this list with inactive licenses'
For Each key In inactiveDict
If activeDict.Exists(key) Then
rowNum = Application.Match(key, .Range("A:A"), False)
Else:
rowNum = Application.WorksheetFunction.CountA(wsNew.Range("A:A")) + 1
.Cells(rowNum, 1).Value = key
End If
.Cells(rowNum, 3).Value = inactiveDict(key)
Next
End With
'Cleanup:
Set activeDict = Nothing
Set inactiveDict = Nothing
End Sub
Sub AddItemToDict(dict As Object, empName As String, state As String)
'since we will use the same methods on both dictionary objects, '
' it would be best to subroutine this action:'
Dim key As Variant
'check to see if this employee already exists'
If UBound(dict.Keys) = -1 Then
dict.Add empName, state
Else:
If Not dict.Exists(empName) Then
'If IsError(Application.Match(empName, dictKeys, False)) Then
'employee doesn't exist, so add to the dict'
dict.Add empName, state
Else:
'employee does exist, so update the list:'
'concatenate the state list'
state = dict(empName) & ", " & state
'remove the dictionary entry'
dict.Remove empName
'add the updated dictionary entry'
dict.Add empName, state
End If
End If
End Sub