How to get filtered data as rowsource of multicolumn listbox? - excel

Question

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.

Answer 1

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

Answer 2

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

Answer 3

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