How to add multiple rowsources to a MSForms listbox - excel

been trying to set multiple ranges to a listbox, while filtering my sheet.
I tried this one, but it gives me a runtime error.
ListBox1.RowSource = Sheets("Sheet1").Range("A1:F1,A15:F15").Address
Is it possible to do something like this?
Edit: I could run this without error
ListBox1.RowSource = Sheets("Sheet1").Range("A1:F1", "A15:F15").Address
But it fills the list with Row 1 until 15, not only 1 and 15...

You cannot set a discontinuous range as a list box RowSource, but you can use a trick. I mean to create an array then fill it with the discontinuous range areas and load the list box using its List property.
Please, copy the next code in the UserForm_Initialize event and show the form:
Private Sub UserForm_Initialize()
Dim arr, rng As Range, sh As Worksheet, K As Long
Dim aRng As Range, C As Range
Set sh = ActiveSheet
Set rng = sh.Range("A1:F1,A3:F3")
ReDim arr(1 To rng.cells.count)
For Each aRng In rng.Areas
For Each C In aRng
K = K + 1: arr(K) = C.Value
Next
Next
Me.ListBox1.list = Application.Transpose(arr)
End Sub
The above solution works to load the array with one single column containing all cells in the discontinuous range.
In order to fill the array with as many columns are in the two ranges (6) and two rows, I will prepare another piece of code and post in some minutes.
Please, test the next code (copied inside Initialeze event):
Private Sub UserForm_Initialize()
Dim sh As Worksheet, aArr, fArr, combinedArr
Set sh = ActiveSheet
With Application
aArr = .Index(Range("A1:F1").Value, 1, 0)
fArr = .Index(Range("A3:F3").Value, 1, 0)
combinedArr = .Transpose(Array(aArr, fArr))
End With
With Me.ListBox1
.Clear
.ColumnCount = 6
.list = Application.Transpose(combinedArr)
End With
End Sub

Related

New column of unique names VBA [duplicate]

This question already has an answer here:
Can we put dictionary items(array) into a Range with a single statement?
(1 answer)
Closed 6 months ago.
At the moment I have a range of names, and I need to create a new column which only contains the unique names.
Sub Unique_Values()
mySheet = Sheets("Sheet1").Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In mySheet
a = .Item(cell)
Next
Range("D2").Value = Join(.keys, vbLf)
End With
End Sub
This code creates a dictionary and returns the list of unique names, but it's one long list (i've just inserted it into D2) but I need it to populate column D with the unique names, one name per cell. I can't quite figure out how to loop through the keys and put them into an individual cell
Please, try the next updated code:
Sub Unique_Values()
Dim MySheet As Worksheet, rng As Range, cell As Range
Set MySheet = Sheets("Sheet1")
Set rng = MySheet.Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In rng.cells
.item(cell.Value) = 1
Next
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It is good to declare all necessary variable, naming them in a relevant way.
Then, dict.keys is a 1D array (not having rows) and to place it in a column, it needs to be transposed.
I only tried adapting your code as it is. To make it faster, the iterated range should be placed in an array and then all the array processing will be done in memory, resulting a faster result. Anyhow, for the range you show us (if this is the real one), processing should take less than a second...
In fact, the faster version is easy to be designed, so here it is:
Sub Unique_Values_Array()
Dim MySheet As Worksheet, arr, i As Long, j As Long
Set MySheet = Sheets("Sheet1")
arr = MySheet.Range("E9:I20").Value2
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
.item(arr(i, j)) = 1
Next j
Next i
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It makes sense and speed difference only in case of larger ranges...
If you use a collection you can create a unique list and write to the range. A collection will not let you add the same index key twice, therefore we ignore the error and then resume error checking when done writing.
Sub test()
Dim myNames As New Collection
Dim mySheet As Range
Dim i As Long
Set mySheet = Sheets("Sheet1").Range("E9:I20")
On Error Resume Next
For Each cell In mySheet
myNames.Add cell, cell.Value
Next
On Error GoTo 0
For i = 1 To myNames.Count
Worksheets("Sheet1").Cells(i + 2, 4) = myNames(i)
Next
End Sub

Delete all rows containing values outside of a specified numeric range

I am completely new to visual basic. I have a few spreadsheets containing numbers. I want to delete any rows containing numbers outside of specific ranges. Is there a straightforward way of doing this in visual basic?
For example, in this first spreadsheet (image linked) I want to delete rows that contain cells with numbers outside of these two ranges: 60101-60501 and 74132-74532.
Can anyone give me some pointers? Thanks!
Code
You need to call it for your own needs as shown on the routine "Exec_DeleteRows". I assumed that you needed if it is equals or less to the one that you state on your routine. In this example, I will delete the rows where values are between 501-570 and then the ones between 100-200
Sub Exec_DeleteRows()
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 501, 570)
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 100, 200)
End Sub
Sub Exec_DeleteRowsInRangeBasedOnNumberValue(RangeToWorkIn As Range, NumPivotToDeleteRowBottom As Double, NumPivotToDeleteRowTop As Double)
Dim RangeRowsToDelete As Range
Dim ItemRange As Range
For Each ItemRange In RangeToWorkIn
If IsNumeric(ItemRange.Value) = False Then GoTo SkipStep1
If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop Then ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
If RangeRowsToDelete Is Nothing Then ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = RangeToWorkIn.Parent.Rows(ItemRange.Row)
Else ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = Union(RangeToWorkIn.Parent.Rows(ItemRange.Row), RangeRowsToDelete)
End If ' 2. If RangeRowsToDelete Is Nothing
End If ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
SkipStep1:
Next ItemRange
If Not (RangeRowsToDelete Is Nothing) Then RangeRowsToDelete.EntireRow.Delete
End Sub
Demo
Delete Rows Containing Wrong Numbers
It is assumed that the data starts in A1 of worksheet Sheet1 in the workbook containing this code (ThisWorkbook) and has a row of headers (2).
This is just a basic example to get familiar with variables, data types, objects, loops, and If statements. It can be improved on multiple accounts.
Option Explicit
Sub DeleteWrongRows()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' worksheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' range
Application.ScreenUpdating = False
Dim rrg As Range ' Row Range
Dim rCell As Range ' Cell in Row Range
Dim rValue As Variant ' Value in Cell
Dim r As Long ' Row
Dim DoDelete As Boolean
' Loop backwards through the rows of the range.
For r = rg.Rows.Count To 2 Step -1
Set rrg = rg.Rows(r)
' Loop through cells in row.
For Each rCell In rrg.Cells
rValue = rCell.Value
If IsNumeric(rValue) Then ' is a number
If rValue >= 60101 And rValue <= 60501 Then ' keep
ElseIf rValue >= 74132 And rValue <= 74532 Then ' keep
Else ' delete (outside the number ranges)
DoDelete = True
End If
Else ' is not a number
DoDelete = True
End If
If DoDelete Then ' found a cell containing a wrong value
rCell.EntireRow.Delete
DoDelete = False
Exit For ' no need to check any more cells
'Else ' found no cell containing a wrong value (do nothing)
End If
Next rCell
Next r
Application.ScreenUpdating = True
MsgBox "Rows with wrong numbers deleted.", vbInformation
End Sub
Using Range.Delete is the built-in way of completely erasing a row in Excel VBA. To check an entire row for numbers meeting a certain criteria, you would need a Loop and an If Statement.
To evaluate a lot of values at a faster pace, it is smart to first grab the relevant data off the Excel sheet into an Array. Once in the array, it is easy to set up the loop to run from the first element (LBound) to the final element (UBound) for each row and column of the array.
Also, when deleting a lot of Ranges from a worksheet, it is faster and less messy to first collect (Union) the ranges while you're still looping, and then do the delete as a single step at the end. This way the Range addresses aren't changing during the loop and you don't need to re-adjust in order to track their new locations. That and we can save a lot of time since the application wants to pause and recalculate the sheet after every Deletion.
All of those ideas put together:
Sub Example()
DeleteRowsOutside ThisWorkbook.Worksheets("Sheet1"), Array(60101, 60501), Array(74132, 74532)
End Sub
Sub DeleteRowsOutside(OnSheet As Worksheet, ParamArray Min_and_Max() As Variant)
If OnSheet Is Nothing Then Set OnSheet = ActiveSheet
'Find the Bottom Corner of the sheet
Dim BottomCorner As Range
Set BottomCorner = OnSheet.Cells.Find("*", After:=OnSheet.Range("A1"), SearchDirection:=xlPrevious)
If BottomCorner Is Nothing Then Exit Sub
'Grab all values into an array
Dim ValArr() As Variant
ValArr = OnSheet.Range(OnSheet.Cells(1, 1), BottomCorner).Value
'Check each row value against min & max
Dim i As Long, j As Long, DeleteRows As Range
For i = LBound(ValArr, 1) To UBound(ValArr, 1) 'For each Row
For j = LBound(ValArr, 2) To UBound(ValArr, 2) 'For each column
Dim v As Variant: v = ValArr(i, j)
If IsNumeric(v) Then
Dim BoundaryPair As Variant, Is_Within_A_Boundary As Boolean
Is_Within_A_Boundary = False 'default value
For Each BoundaryPair In Min_and_Max
If v >= BoundaryPair(0) And v <= BoundaryPair(1) Then
Is_Within_A_Boundary = True
Exit For
End If
Next BoundaryPair
If Not Is_Within_A_Boundary Then
'v is not within any acceptable ranges! Mark row for deletion
If DeleteRows Is Nothing Then
Set DeleteRows = OnSheet.Rows(i)
Else
Set DeleteRows = Union(DeleteRows, OnSheet.Rows(i))
End If
GoTo NextRow 'skip to next row
End If
End If
Next j
NextRow:
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub Exit For 'skip to next row
End If
End If
Next j
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub
I use a ParamArray to accept a variable number of Min and Max ranges. To keep things tidy, the Min and Max pairs are each in an array of their own. As long as all the numbers in the row are within any of the provided ranges, the row will not be deleted.
Here's some code with Regex and with scripting dictionary that I've been working on. I made this for my purposes, but it may be useful here and to others.
I found a way for selecting noncontinguous cells based on an array and then deleting those cells.
In this case, I selected by row number because VBA prevented deletion of rows due to overlapping ranges.
Sub findvalues()
Dim Reg_Exp, regexMatches, dict As Object
Dim anArr As Variant
Dim r As Range, rC As Range
Set r = Sheets(3).UsedRange
Set r = r.Offset(1).Resize(r.Rows.Count - 1, r.Columns.Count)
Set Reg_Exp = CreateObject("vbscript.regexp")
With Reg_Exp
.Pattern = "^[6-6]?[0-0]?[1-5]?[0-0]?[1-1]?$|^60501$" 'This pattern is for the 60101 to 60501 range.
End With
Set dict = CreateObject("Scripting.Dictionary")
For Each rC In r
If rC.Value = "" Then GoTo NextRC ''skip blanks
Set regexMatches = Reg_Exp.Execute(rC.Value)
If regexMatches.Count = 0 Then
On Error Resume Next
dict.Add rC.Row & ":" & rC.Row, 1
End If
NextRC:
Next rC
On Error GoTo 0
anArr = Join(dict.Keys, ", ")
Sheets(3).Range(anArr).Delete Shift:=xlShiftUp
End Sub

how to get listbox to populate all rows in range only if cell in column h is colored red

I'm trying to populate information from range ("A3:H150") to a list box in a user form, only if the cells in column H are colored red, i.e. .Interior.ColorIndex = 3. The code I have still populates the list box with all data regardless if a cell in column H is red or not.
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Set rngSource = Sheet1.Range("A3:H40")
Dim RNG As Range
Set RNG = Sheet1.Range("H3:H40")
Dim Cell As Range
Set lbtarget = Me.ListBox1
With lbtarget
.ColumnCount = 8
.ColumnWidths = "100;100;100;100;100;100;60;60"
For Each Cell In RNG
If Cell.Interior.ColorIndex = 3 Then
.List = rngSource.Cells.Value
End If
Next
End With
For Each Cell In RNG
If Cell.Interior.ColorIndex = 3 Then
.AddItem Sheet1.Range(Sheet1.Cells(Cell.Row,1),Sheet1.Cells(Cell.Row,8))
End If
Next
End With
This should do it:
Private Sub fillListBox()
Dim myform As UserForm1
Set myform = New UserForm1
Dim loopRange As Range
With Sheet1
Set loopRange = .Range(.Cells(1, 8), .Cells(10, 8))
End With
With myform.ListBox1
Dim Cell As Range
Dim indexCounter As Long
indexCounter = -1
For Each Cell In loopRange
If Cell.Interior.ColorIndex= 3 Then
indexCounter = indexCounter + 1
.AddItem Sheet1.Cells(Cell.Row, 1).Value
Dim colCounter As Long
For colCounter = 2 To 8
.List(indexCounter, colCounter - 1) = Sheet1.Cells(Cell.Row, colCounter).Value
Next
'
End If
Next
End With
End Sub
Assign restructured array to .List property
Procedure doFillListBox
Restructures the entire data set via the Application.Index() function as well as two help functions and
assigns the restructured array to the indicated listbox via its .List property in one single code line, also known as Array method; see section [1]) (instead of adding listbox items one by one, aka as AddItem method).
layouting is done in section [2]:
Sub doFillListBox(lbTarget As MSForms.ListBox, rng As Range)
With lbTarget
' =============================
' [1] restructure listbox items
' -----------------------------
.List = Application.Index(rng.Value, getRowNums(rng), getColNums(rng))
' =============================
' [2] layout listbox
' -----------------------------
.ColumnCount = rng.Columns.Count
.ColumnWidths = "100;100;100;100;100;100;60;60"
End With
End Sub
Related link: Some pecularities of the Application.Index function
Helper functions called by above procedure
Function getRowNums(rng As Range, _
Optional ByVal ColNo As Long = 8, _
Optional ByVal backgroundColor = 3) As Variant()
' Purpose: return "vertical" array with row numbers not marked in red background color (e.g.3)
' Note: column number default is the 8th column, default background color is red (3)
Dim n&
n = rng.Rows.Count
' [1] list uncolored row numbers within temporary array
ReDim tmp(1 To n) ' provide for maximum length
Dim i&, ii& ' row numbers in column H, items counter
For i = 1 To n ' iterate through column H cells
If rng.Cells(i, ColNo).Interior.ColorIndex <> backgroundColor Then ' check criteria
ii = ii + 1 ' increment new items counter
tmp(ii) = i ' enter "old" row number
End If
Next i
ReDim Preserve tmp(1 To ii) ' reduce to actually needed length
' [2] return "vertical" list of needed row numbers
getRowNums = Application.Transpose(tmp) ' transpose to 2-dim array
End Function
Function getColNums(rng As Range) As Variant()
' Purpose: return all column numbers in a "flat" array, e.g. via Array(1,2,3,4,5,6,7,8)
getColNums = Application.Transpose(Evaluate("row(1:" & rng.Columns.Count & ")"))
End Function
Example call
Assuming you want to use the click event of a command button control to populate a given ListBox by referencing the data range e.g. via the sheet's CodeName:
Private Sub CommandButton1_Click()
' Note: change control names and range reference following your needs
doFillListBox Me.ListBox1, Sheet1.Range("A3:H150") ' reference e.g. to CodeName Sheet1
End Sub
Note: The (Name) property is the sheet's CodeName identifier in the VB Editor's Tool window as opposed to the user-modifiable "tab" Name of the worksheet.

Empty ListBox Values

I have 3 Listboxes. In the properties I have selected the ListStyle as fmListStyleOption and the MultiSelect as fmMultiSelectMulti. Here is the current code:
Private Sub Userform_Initialize()
Me.lstProperties.RowSource = "FilterData"
Me.lstStmts.RowSource = "ListofProps"
Me.lstLoans.RowSource = "FilterLoans"
End Sub
I am using dynamic named ranges in hope that it will only show data in the Listbox for cells that actually have values. Unfortunately it shows a long list of blank lines with checkboxes anyways.
Does anyone know how to make sure that the Listbox only shows data with values i.e. if there are 2 cells in my named range with data then there are only two checkboxes in my listbox.
Visual
An easier why to do this would be to create an array from your range and assign the array to the Listbox.List property. This will allow you to use SpecialCells to filter the data.
Private Sub Userform_Initialize()
Me.lstProperties.List = getArrayFromRange(Range("FilterData").SpecialCells(xlCellTypeVisible))
Me.lstStmts.List = getArrayFromRange(Range("ListofProps").SpecialCells(xlCellTypeConstants))
Me.lstLoans.RowSource = getArrayFromRange(Range("FilterLoans").SpecialCells(xlCellTypeConstants))
End Sub
Function getArrayFromRange(rng As Range)
Dim arr
Dim a As Range
Dim count As Long, x As Long, y As Integer
ReDim arr(1 To rng.CountLarge, 1 To rng.Columns.count)
For Each a In rng.Areas
For x = 1 To a.Rows.count
count = count + 1
For y = 1 To rng.Columns.count
arr(count, y) = a.Cells(x, y).Value
Next
Next
Next
getArrayFromRange = arr
End Function
The issue was that my dynamic named range was not properly set up. The formula for the named range should have been:
=OFFSET('Property Data'!$A$5,2,,COUNTA('Property Data'!$A$5),14)
and not:
=OFFSET('Property Data'!$A$5,2,,COUNTA('Property Data'!$A$5:N$5),14).

Copy column cell data using RefEdit Userform

I'm trying to copy masses of information from one spreadsheet to another to make it easier to print out on one piece of paper. All the data is set out in sequence and in columns and they need to be printed as such.
I'm trying to create a userform to speed this up by copying different column ranges and pasting them in to another spreadsheet in the exact same format but in columns of 50 cells and a maximum of 4 columns per sheet of paper.
This is what I've got so far, but it only copies the first cell:
Private Sub UserForm_Click()
UserForm1.RefEdit1.Text = Selection.Address
End Sub
Private Sub CommandButton1_Click()
Dim addr As String, rng
Dim tgtWb As Workbook
Dim tgtWs As Worksheet
Dim icol As Long
Dim irow As Long
Set tgtWb = ThisWorkbook
Set tgtWs = tgtWb.Sheets("Sheet1")
addr = RefEdit1.Value
Set rng = Range(addr)
icol = tgtWs.Cells(Rows.Count, 1) _
.End(xlUp).Offset(0, 0).Column
tgtWs.Cells(1, icol).Value = rng.Value
End Sub
Any help would be greatly appreciated.
Your approach for outputting the data is only referencing a single cell. You use .Cells(1,icol) which will only reference a single cell (in row 1, and a single column).
In order to output the data to a larger range, you need to reference a larger range. The easiest way to do this is probably via Resize() using the size of the RefEdit range.
I believe this will work for you. I changed the last line to include a call to Resize.
Private Sub CommandButton1_Click()
Dim addr As String, rng
Dim tgtWb As Workbook
Dim tgtWs As Worksheet
Dim icol As Long
Dim irow As Long
Set tgtWb = ThisWorkbook
Set tgtWs = tgtWb.Sheets("Sheet1")
addr = RefEdit1.Value
Set rng = Range(addr)
icol = tgtWs.Cells(Rows.Count, 1) _
.End(xlUp).Offset(0, 0).Column
tgtWs.Cells(1, icol).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End Sub
Edit: I went ahead and created a dummy example to test this out:
Click the button and it pastes

Resources