Populate single listbox merging different ranges from different sheets

[pootheyes]

Hi all,
I need to populate in a userform a single multicolumn listbox merging different ranges from different sheets.

This is the code:



Private Sub UserForm_Initialize()
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells(Rows.Count, "I").End(xlUp).Row + 1
Data = Sheets("Sheet1").Range("A4:I" & LastRow)
With ListBoxPazienti
.ColumnCount = 9
.ColumnWidths = "100"
.List = Data
.ListIndex = -1
End With
End Sub

I would populate this listbox with data of multiple sheets named "Sheet1", "Sheet2", "Sheet3", etc.

All sheets have the same number and name of the columns.

Is it possible? Is there a vba code?

Thanks in advance.

Kind regards,
Fabrizio

[GTO]

Greetings and welcome to VBAX :hi:,

I am awfully rusty (a year away!), but this appears to work:



Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim N As Long
Dim lCol As Long
Dim lRow As Long
Dim RowInColOne As Long
Dim ColumnInCurrentRow As Long
Dim MyArray As Variant
Dim MyData As Variant
Dim bHasData As Boolean

With ListBoxPazienti
.ColumnCount = 9
.ColumnWidths = "100"
End With

MyArray = Array("Sheet1", "Sheet2", "Sheet3")

For N = LBound(MyArray) To UBound(MyArray)
If ShExists(MyArray(N), ThisWorkbook) Then
LastRow = ThisWorkbook.Worksheets(MyArray(N)).Cells(ThisWorkbook.Worksheets(MyArray(N )).Rows.Count, "I").End(xlUp).Row + 1
MyData = ThisWorkbook.Worksheets(MyArray(N)).Range("A4:I" & LastRow).Value
For RowInColOne = 1 To UBound(MyData)
ListBoxPazienti.AddItem MyData(RowInColOne, 1)
For ColumnInCurrentRow = 2 To UBound(MyData, 2)
ListBoxPazienti.List(ListBoxPazienti.ListCount - 1, ColumnInCurrentRow - 1) = MyData(RowInColOne, ColumnInCurrentRow)
Next
Next
bHasData = True
End If
Next N

If bHasData Then ListBoxPazienti.ListIndex = -1

End Sub


Hope that helps,

Mark

PS. - Not sure why you are adding a row to LastRow, as this would seem to grab a blank row? I'll try and check back tomorrow.

[Kenneth Hobs]

Welcome to the forum!

CombineTwodArrays(): See http://www.cpearson.com/excel/VBAArrays.htm

[pootheyes]

Greetings and welcome to VBAX :hi:,

I am awfully rusty (a year away!), but this appears to work:



Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim N As Long
Dim lCol As Long
Dim lRow As Long
Dim RowInColOne As Long
Dim ColumnInCurrentRow As Long
Dim MyArray As Variant
Dim MyData As Variant
Dim bHasData As Boolean

With ListBoxPazienti
.ColumnCount = 9
.ColumnWidths = "100"
End With

MyArray = Array("Sheet1", "Sheet2", "Sheet3")

For N = LBound(MyArray) To UBound(MyArray)
If ShExists(MyArray(N), ThisWorkbook) Then
LastRow = ThisWorkbook.Worksheets(MyArray(N)).Cells(ThisWorkbook.Worksheets(MyArray(N )).Rows.Count, "I").End(xlUp).Row + 1
MyData = ThisWorkbook.Worksheets(MyArray(N)).Range("A4:I" & LastRow).Value
For RowInColOne = 1 To UBound(MyData)
ListBoxPazienti.AddItem MyData(RowInColOne, 1)
For ColumnInCurrentRow = 2 To UBound(MyData, 2)
ListBoxPazienti.List(ListBoxPazienti.ListCount - 1, ColumnInCurrentRow - 1) = MyData(RowInColOne, ColumnInCurrentRow)
Next
Next
bHasData = True
End If
Next N

If bHasData Then ListBoxPazienti.ListIndex = -1

End Sub


Hope that helps,

Mark

PS. - Not sure why you are adding a row to LastRow, as this would seem to grab a blank row? I'll try and check back tomorrow.

Thanks a lot for your help. I added a blank row at the end only to check the beginning of the new sheet during my test.

I will try your code as soon as possible.
Let you know asap.

Thanks again

[pootheyes]

Dear GTO the code is perfect, I have only one problem with If ShExists(MyArray(N), ThisWorkbook) Then but I removed this line.
Now I am trying to filter the listbox by 3 textboxes.
I hope well. :think:

Thanks
Fabrizio

[pootheyes]

Hi GTO, hi all,
I have many problem to filter the listbox when one ore more textboxes change.

With one textbox (surname) I do not have any problems. But I'm not able to add other filters in the same time and for all sheet.

For your interest, after I will fix the filter by textboxes, I would to be able to:

- add new records
- update records
- delete records

This is the code on textbox changes


Public LastRow As Long
Private Sub FilterList(iCtrl As Long, sText As String)
Dim iRow As Long
Dim sCrit As String
sCrit = "*" & UCase(sText) & "*"
With Me.ListBoxPazienti

LastRow = Range("I65536").End(xlUp).Row
.List = Range("A4:I" & LastRow).Value

For iRow = .ListCount - 1 To 0 Step -1
If Not UCase(.List(iRow, iCtrl)) Like sCrit Then
.RemoveItem iRow
End If
Next iRow
End With
End Sub

Private Sub txtCercaSurname_Change()
FilterList 0, Me.txtCercaSurname.Text
End Sub

Private Sub txtCercaName_Change()
FilterList 0, Me.txtCercaSurname.Text
FilterList 1, Me.txtCercaName.Text
End Sub


This is my file test
23538

Could you help me?

Thanks in advance,
Fabrizio

[GTO]

Dear GTO the code is perfect, I have only one problem with If ShExists(MyArray(N), ThisWorkbook) Then but I removed this line.
Now I am trying to filter the listbox by 3 textboxes.
I hope well. :think:

Thanks
Fabrizio

Hi Fabrizio,

Apologies, I forgot to include the Function, which would go in a Standard Module



Function ShExists(ShName As String, _
Optional wb As Workbook, _
Optional CheckCase As Boolean = False) As Boolean

If wb Is Nothing Then
Set wb = ThisWorkbook
End If

If CheckCase Then
On Error Resume Next
ShExists = CBool(wb.Worksheets(ShName).Name = ShName)
On Error GoTo 0
Else
On Error Resume Next
ShExists = CBool(UCase(wb.Worksheets(ShName).Name) = UCase(ShName))
On Error GoTo 0
End If
End Function


:

This way we check to make sure the sheet exists before working with it.

Mark

[pootheyes]

Hi Fabrizio,

Apologies, I forgot to include the Function, which would go in a Standard Module



Function ShExists(ShName As String, _
Optional wb As Workbook, _
Optional CheckCase As Boolean = False) As Boolean

If wb Is Nothing Then
Set wb = ThisWorkbook
End If

If CheckCase Then
On Error Resume Next
ShExists = CBool(wb.Worksheets(ShName).Name = ShName)
On Error GoTo 0
Else
On Error Resume Next
ShExists = CBool(UCase(wb.Worksheets(ShName).Name) = UCase(ShName))
On Error GoTo 0
End If
End Function


:

This way we check to make sure the sheet exists before working with it.

Mark
Thanks