View Full Version : Populate single listbox merging different ranges from different sheets
pootheyes
01-08-2019, 10:24 AM
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
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
01-08-2019, 02:37 PM
Welcome to the forum!
CombineTwodArrays(): See http://www.cpearson.com/excel/VBAArrays.htm
pootheyes
01-08-2019, 05:08 PM
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
01-09-2019, 02:43 AM
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
01-09-2019, 10:17 AM
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
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
01-09-2019, 11:47 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.