After running the Userform_Initialize() event, there would be nothing populated in the listbox as shown below:
There should be 11 columns populating the listbox based on the excel table below:
The code ran:
Private Sub UserForm_Initialize()
Dim Total_rows_FoilProfile As Long
Dim row As Range, i As Long
Total_rows_FoilProfile = TotalRowsCount(ThisWorkbook.Name, "Foil Profile", "tblFoilProfile")
ReDim MyArr(0 To Total_rows_FoilProfile - 1)
For Each row In ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile").Range.SpecialCells(xlCellTypeVisible).Rows
MyArr(i) = row.Value
i = i + 1
Next row
lbxFoilInfoDisplay.List = MyArr
frmFoilPanel.Show
The properties of the listbox:
You can populate each list row and then add the columns to it:
Option Explicit
Private Sub UserForm_Initialize()
Dim tblFoilProfile As ListObject
Set tblFoilProfile = ThisWorkbook.Worksheets("Foil Profile").ListObjects("tblFoilProfile")
Dim i As Long
lbxFoilInfoDisplay.Clear
Dim iListRow As Range
For Each iListRow In tblFoilProfile.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
With Me.lbxFoilInfoDisplay
.AddItem iListRow.Cells(1, 1).Value 'add first value (column 1)
Dim iCol As Long
For iCol = 2 To iListRow.Columns.Count 'add all other columns to that row
.list(i, iCol) = iListRow.Cells(1, iCol).Value '.Value for unformatted value or .Text to show it in the same format as in the cell
Next iCol
i = i + 1
End With
Next iListRow
End Sub
Note here is a nice guide how to work with list objects.
Related
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
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 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 data in Sheet2 as like below.
Actual Data
Then I manually apply filer to those data which looks like...
Filtered Data
I have a user form (UserForm1) and a list box (ListBox1) in the form. Also have a command button cmdFilteredData. So, I want to fill the listbox with filtered data only. I make below codes but it gives Type mismatch error.
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Set FilteredRange = Sheet2.Range("A1:C5").Rows.SpecialCells(xlCellTypeVisible)
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.RowSource = FilteredRange
End With
End Sub
Any help is hearty appreciated.
Since you are trying to populate the ListBox1 with values from filtered range, you have blank rows in the middle, this "messes" up the ListBox.
Instead, you can copy>>Paste the value to columns on the right (or another worksheet), use an array to populate these values, and then populate the ListBox1 with the array.
Code
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Dim myArr As Variant
Set FilteredRange = ThisWorkbook.Sheets("Sheet8").Range("A1:C5").SpecialCells(xlCellTypeVisible)
' copy filtered range to the columns on the right (if you want, you can add a "Dummy" sheet), to have the range continous
FilteredRange.Copy Range("Z1")
' populae the array with new range values (without blank rows in the middle)
myArr = Range("Z1").CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Alternative Function to - unreliable - SpecialCells(xlCellTypeVisible)
This answer intends to complete Shai Rado's appreciated solution, not to correct it.
Testing the above solution, however showed that using SpecialCells(xlCellTypeVisible) and/or reference to CurrentRegion might result in problems (even within OP's small range).
A possible work around function (esp. for udfs) is presented at SpecialCells(xlCellTypeVisible) not working in UDF.
Private Function VisibleCells(rng As Range) As Range
' Site: https://stackoverflow.com/questions/43234354/specialcellsxlcelltypevisible-not-working-in-udf
' Note: as proposed by CalumDA
Dim r As Range
For Each r In rng
If r.EntireRow.Hidden = False Then
If VisibleCells Is Nothing Then
Set VisibleCells = r
Else
Set VisibleCells = Union(VisibleCells, r)
End If
End If
Next r
End Function
Shai Rado's solution slightly modified (cf. above notes)
In any case the target range has to be cleared before copying and then better referenced without CurrentRegion, so that you get the wanted items only. These changes worked for me.
Option Explicit
Private Sub cmdFilteredData_Click()
Dim ws As Worksheet
Dim sRng As String
Dim FilteredRange As Range
Dim myArr As Variant
Dim n As Long
Set ws = ThisWorkbook.Worksheets("Filtered")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' get last row
sRng = "A1:C" & n
' Set FilteredRange = ws.Range(sRng).SpecialCells(xlCellTypeVisible) ' << not reliable
Set FilteredRange = VisibleCells(ws.Range(sRng)) ' <<<< possible ALTERNATIVE
' clear target range in order to allow correct array fillings later !
ws.Range("Z:AAB").Value = ""
' copy filtered range to the columns on the right
FilteredRange.Copy ws.Range("Z1")
' populate the array with new range values (without blank rows in the middle)
' myArr = ws.Range("Z1").CurrentRegion ' sometimes unreliable, too
myArr = ws.Range("Z1:AAB" & ws.Range("Z" & ws.Rows.Count).End(xlUp).Row) ' <<< better than CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Links mentioned in cited post:
Microsoft - udf not working
ExcelForum - xlCelltypeVisible not working
MrExcel - SpecialCells not working
I was searching a lot for that but I couldn't fine any elegant solution for doing it without pasting data in the sheet. So I create my own function to convert visible cells of range into an array.
Maybe it's not the smartest way, but works just fine an quite fast.
Function createArrFromRng(rng As Range)
Dim sCellValues() As Variant
Dim col, row, colCount, RowCount As Integer
col = 0
row = 0
colCount = 0
RowCount = 0
On Error GoTo theEnd
Set rng = rng.SpecialCells(xlCellTypeVisible)
'get the columns and rows size
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
Next cell
'set the array size
ReDim Preserve sCellValues(RowCount - 1, colCount - 1)
col = 0
row = 0
colCount = 0
RowCount = 0
'get the values and add to the array
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
'Debug.Print colCount
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
sCellValues(RowCount - 1, colCount - 1) = cell.value
Next cell
theEnd:
createArrFromRng = sCellValues
End Function
I have been developing a UserForm that uses a listbox populated by the A column to delete specific rows based on listbox selection. But when I click the "Apply" button it takes a ridiculously long time until it processed and deleted the rows.
The code for the Apply button is the following, there is almost no other code in the UserForm. Just Me.Hide in the Cancel button.
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Me.ListBox1.Selected(i) Then
Else
col.Add i + 1
End If
Next i
' Then delete the rows
Set rng = Worksheets("Sheet1").Range("A1:A100")
For Each itm In col
rng.Rows(itm).EntireRow.Delete
Next itm
blnCancel = False
Me.Hide
End Sub
I think you'd be better off collecting the non-selected items into a Range in your loop and then just deleting that:
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Not Me.ListBox1.Selected(i) Then
If rng Is Nothing then
Set rng = Worksheets("Sheet1").Range("A" & i + 1)
Else
Set rng = Union(rng, Worksheets("Sheet1").Range("A" & i + 1))
End If
End If
Next i
' Then delete the rows
If not rng Is Nothing then rng.Entirerow.delete
blnCancel = False
Me.Hide
End Sub