Listbox, fill by format

[Steve]

I am trying to load a listbox by using the cell format as my filter. The
following routine creates a collection of cells that are gray with yellow
text. The problem is, I can only load the last cell into the listbox. Any
help with that final step would be greatly appreciated. An added bonus would
be to limit it to a range.

Thanks,
Steve



Sub ProductGroupFormat()
Dim AllCells As Range, FirstCell As Range, FoundCell As Range
Dim ProductGroup As New Collection

UserForm2.ListBox2.Clear

With Application.FindFormat
.Clear
.Interior.ColorIndex = 15
.Font.ColorIndex = 36
End With

Set FirstCell = ActiveSheet.UsedRange.Find(what:="",
searchformat:=True)

Set AllCells = FirstCell
Set FoundCell = FirstCell

Do
Set FoundCell = ActiveSheet.UsedRange.Find(After:=FoundCell,
what:="", searchformat:=True)
If FoundCell Is Nothing Then Exit Do
Set AllCells = Union(FoundCell, AllCells)
If FoundCell.Address = FirstCell.Address Then Exit Do
Loop

ProductGroup.Add AllCells.Value

For Each Item In ProductGroup
UserForm2.ListBox2.AddItem Item
Next Item

UserForm2.Show

End Sub

 

[Gary Keramidas]

one way may be to create the values in a contiguous range on a hidden sheet and
populate the listbox from there.

 

[Steve]

That is what I currently have. Two drawbacks to that is, one, it doesn’t
easily allow someone to add a cell (with that format) and have it
automatically be in the listbox. The other is, I sometimes get error
messages as a result of the list being on a separate worksheet.

 

[Rick Rothstein \(MVP - VB\)]

Can you make use of this? The following Sub assumes you have already colored
the cells/fonts elsewhere... all it does is look through a range and load
the cell's value into ListBox2 on UserForm2 (these can be made parameters to
the Sub if you want to generalize the subroutine more) if the cell's
Interior.ColorIndex and Font.ColorIndex match the values passed in to the
Sub via the 2nd and 3rd arguments. Here is the Sub...

Sub FillListBox(RangeIn As Range, _
CellColorIndex As Long, _
TextColorIndex As Long)
Dim R As Range
For Each R In RangeIn
If R.Interior.ColorIndex = CellColorIndex And _
R.Font.ColorIndex = TextColorIndex Then
UserForm2.ListBox2.AddItem CStr(R.Value)
End If
Next
End Sub

You might call it like this...

FillListBox Range("A1:F23"), 15, 36

using your sample colors.

Rick

 

[Steve]

Thanks Rick,

That worked out great. For the sake of anyone else, that might find this
useful, I have included the final procedures:

Sub ListBox()
UserForm2.ListBox2.Clear
Call FillListBox(Range("B1:B1000"), 15, 36)
UserForm2.Show
End Sub

Sub FillListBox(RangeIn As Range, CellColorIndex As Long, TextColorIndex As
Long)
Dim R As Range
For Each R In RangeIn
If R.Interior.ColorIndex = CellColorIndex And _
R.Font.ColorIndex = TextColorIndex Then
UserForm2.ListBox2.AddItem CStr(R.Value)
End If
Next
End Sub

 

[Steve]

Rick,

Yet, one little hang-up. I put this in the user form code and keep getting
an error message "Object variable or With block variable not set". I am
guessing that it may be the “R†variable that needs to be Set. I’m not sure
though. Oddly enough, it goes through the whole routine (like planned) in
spite of the error message.


Private Sub UserForm_Initialize()
'ProductGroupForm.ProductListBox.Clear
Call FillListBox(Range("M8:M1000"), 15, -4105)
ProductGroupForm.Show
End Sub

Sub FillListBox(RangeIn As Range, CellColorIndex As Long, TextColorIndex As
Long)
Dim R As Range
For Each R In RangeIn
If R.Interior.ColorIndex = CellColorIndex And R.Font.ColorIndex =
TextColorIndex Then
ProductGroupForm.ProductListBox.AddItem CStr(R.Value)
End If
Next
End Sub

Private Sub ProductListBox_Click()

Dim iFind As Range
Dim iSearch As Range
Dim iValue As String
Dim llProductGroupRow As Long

iValue = ProductListBox.Value
Set iSearch = Worksheets("Costsheet").Range("M8:M1000")

Application.ScreenUpdating = False

With iSearch
Set iFind = .Find(iValue)
If Not iFind Is Nothing Then
iFind.Activate
End If
End With

llProductGroupRow = ActiveCell.Row

Range("A" & llProductGroupRow).Activate
Application.GoTo Reference:=ActiveCell, Scroll:=True

Unload Me

End Sub