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 ,

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 ,

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.

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
Rubrica_Test.xlsm

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.

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