fixing code rowsource in listbox through all sheets

H

Hasson

Active Member
Joined
Apr 8, 2021
Messages
388
Office Version
  1. 2016
Platform
  1. Windows
hi
I have this code to show dat in listbox a based on active sheet.
VBA Code: 
Private Sub UserForm_Initialize()
   MyRowSource = "A2:d" & Str(activesheet.Cells.SpecialCells(xlCellTypeLastCell).Row)
    MyRowSource = Replace(MyRowSource, " ", "")
    ListBox1.RowSource = MyRowSource
    Next
End Sub

I try showing data in list box throught all sheets but so far not work

Code: 
Private Sub UserForm_Initialize()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets

   MyRowSource = "A2:d" & Str(ws.Cells.SpecialCells(xlCellTypeLastCell).Row)
    MyRowSource = Replace(MyRowSource, " ", "")
    ListBox1.RowSource = MyRowSource
    Next
End Sub
any help to fix it ?
 
Sort by date Sort by votes
@EXCEL MAX wow ! you're absolutely proffesional . thanks again

sorry I'm asking too much just last thing . can you add function sum to summing the values for duplicate items based on the second column in list box based on COL B and the values should summing in last column in list box based on COL D . I mean should merge duplicated items in listbox
thanks for your cooperation .
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Suppose your data starts from "A1" and you have four columns with headers.
Also, suppose you have userform with listbox and three option buttons.
When you initiate userform the listbox will show data from all sheets, from columns "A:D", one below each other.
Also listbox will merge all rows with same items in the column "B", and the values in the column "D" will be added.
When you activate some option button The code will show merged data and added values only for specific sheet.
VBA Code: 
Dim ws As Worksheet
Dim vA(), vA2(), vA3()
Dim vSum As Double
Dim vR As Long, vN As Long, vN2 As Long, vC As Long

Private Sub UserForm_Initialize()

    Call AllRows
    Call MergeAndSumUnique
'display in the listbox
    ListBox1.ColumnCount = 4
    ListBox1.List() = vA3
   
End Sub

Sub AllRows()
    
    Dim vRAll As Long
'calculate the final size
    For Each ws In Worksheets
         vR = ws.Cells(Rows.Count, "A").End(xlUp).Row - 1
         vRAll = vRAll + vR
    Next ws
'resize array
    ReDim vA(1 To vRAll, 1 To 4)
'fill array
    vC = 1
    For Each ws In Worksheets
        vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
        For vN = 2 To vR
            vA(vC, 1) = ws.Cells(vN, 1)
            vA(vC, 2) = ws.Cells(vN, 2)
            vA(vC, 3) = ws.Cells(vN, 3)
            vA(vC, 4) = ws.Cells(vN, 4)
            vC = vC + 1
        Next vN
    Next ws
    vC = 0
    
End Sub

Sub MergeAndSumUnique()
    
    Dim vD, vAdded As Long, vMR As Long
'create one dimensional array from column "B"
    ReDim vA2(1 To UBound(vA))
    For vN = 1 To UBound(vA)
        vA2(vN) = vA(vN, 2)
    Next vN
'create aray with unique values from column "B"
    With CreateObject("Scripting.Dictionary")
        For Each vD In vA2
            If Not .exists(vD) Then
                .Add vD, .Count
            End If
        Next vD
'create two dimensional array with unique values
        vA2 = Application.Transpose(.keys)
'resize new two dimensional array
        ReDim vA3(1 To .Count, 1 To 4)
    End With
'fill final array
    For vN = 1 To UBound(vA2)
        For vN2 = 1 To UBound(vA)
'but before, compare unique items with items in the column "B"
'if match, sum duplicate values in the column "D"
            If vA2(vN, 1) = vA(vN2, 2) Then
                If vMR = 0 Then vMR = vN2
                vSum = vSum + vA(vN2, 4)
            End If
        Next vN2
        vA3(vN, 1) = vA(vMR, 1)
        vA3(vN, 2) = vA(vMR, 2)
        vA3(vN, 3) = vA(vMR, 3)
        vA3(vN, 4) = vSum
        vSum = 0
        vMR = 0
    Next vN
   
End Sub

Sub OneSheetRows()
    
    vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
    If Not vR = 1 Then
'resize array
        ReDim vA(1 To vR - 1, 1 To 4)
        vC = 1
 'fill array
        For vN = 2 To vR
            vA(vC, 1) = ws.Cells(vN, 1)
            vA(vC, 2) = ws.Cells(vN, 2)
            vA(vC, 3) = ws.Cells(vN, 3)
            vA(vC, 4) = ws.Cells(vN, 4)
            vC = vC + 1
        Next vN
        vC = 0
        Call MergeAndSumUnique
  End If
    
End Sub

Private Sub sh1_Change()
        
    Set ws = Sheets("sh1")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
    
End Sub

Private Sub fgj1_Change()
    
    Set ws = Sheets("fgj1")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
    
End Sub

Private Sub zxc_Change()

    Set ws = Sheets("zxc")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
    
End Sub
 
Upvote 0
you're super great ! awesome ,fantastic what I can say . you provide me a great help . few members do that .

I can follow your code and understand how modified about expanding data I succedd so , but shows some problem about width columns 3,4 are very close for each othe of them as in picture .how can I fix it ? and if you have any suggetion about invoice number in COLUMN 5 . any duplicate item in COL B has different invoices numbers .I think if there is way when merge data show in col 5 in listbox for item like this INV1008,009 the current code it takes the first invoice INV1008
1.PNG

thanks again
 
Upvote 0
As first, thanks for respect.
There is many ways to set listbox column width. This is one of them.
Add combobox to userform. In this combobox you can select column you want to sizing.
Add one spin button too.
After choosing column you can change column size with spin button using this code...
VBA Code: 
Dim vColWidth As String, vAColWidth, vResizingSpeed As Integer, vColMin As Integer

Private Sub UserForm_Initialize()
    
'add items to the combobox for each column (without one)
    ComboBox1.AddItem (1)
    ComboBox1.AddItem (2)
    ComboBox1.AddItem (3)
    ComboBox1.ListIndex = 0
'set column resizing speed
    vResizingSpeed = 3
'set minimum column width
    vColMin = 10
    
End Sub

Private Sub SpinButton1_SpinDown()
    
'collect columns widths
    vColWidth = ListBox1.ColumnWidths
'split string to individual items
    vAColWidth = Split(ListBox1.ColumnWidths, ";")
'check for minimum resizing
    If Not Split(vAColWidth(ComboBox1.ListIndex), " ")(0) < vColMin Then
'resize specific column according to the combobox value
        vAColWidth(ComboBox1.Value - 1) = _
             Split(vAColWidth(ComboBox1.ListIndex), " ")(0) _
             - vResizingSpeed
'transform items to the string
        vColWidth = Join(vAColWidth, ";")
'set listbox ColumnWidths property with new values
        ListBox1.ColumnWidths = vColWidth
    End If
        
End Sub

Private Sub SpinButton1_SpinUp()

'similar as SpinUp
    vColWidth = ListBox1.ColumnWidths
    vAColWidth = Split(ListBox1.ColumnWidths, ";")
    vAColWidth(ComboBox1.Value - 1) = _
         Split(vAColWidth(ComboBox1.ListIndex), " ")(0) _
         + vResizingSpeed
    vColWidth = Join(vAColWidth, ";")
    ListBox1.ColumnWidths = vColWidth
        
End Sub
About second problem...
Yes, you are right. Code takes only first row when merging few rows.
In the beginning we were talking about four columns, now I see more columns.
I'm not sure what you want, can you explain?
 
Upvote 0
thanks for your time and patience.
about the width columns if there is way when I run userform should adjust the columns with columns and make smilir spaces among the columns without use combobox or spin button like this 60;60;120 .... but I no know how do this
about the second problem take AA-12 Bfor instance see in sheet as pic 1 see in COL E contains two differnt number invoice INV1000-8,INV1000-9
so when merge in listbox should be INV1000-8,9 as pic 2
1.PNG

see the highlighted last row in listbox in COL 5 how should be
2.PNG



about this
In the beginning we were talking about four columns, now I see more columns.
Click to expand...
don't worry I can tweak your code and succeed this is the whole code after adjusting . every thing works well
VBA Code: 
Dim ws As Worksheet
Dim vA(), vA2(), vA3()
Dim vSum As Double
Dim vR As Long, vN As Long, vN2 As Long, vC As Long

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Initialize()

    Call AllRows
    Call MergeAndSumUnique
'display in the listbox
    ListBox1.ColumnCount = 7
    ListBox1.List() = vA3
 
End Sub

Sub AllRows()
  
    Dim vRAll As Long
'calculate the final size
    For Each ws In Worksheets
         vR = ws.Cells(Rows.Count, "A").End(xlUp).Row - 1
         vRAll = vRAll + vR
    Next ws
'resize array
    ReDim vA(1 To vRAll, 1 To 7)
'fill array
    vC = 1
    For Each ws In Worksheets
        vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
        For vN = 2 To vR
            vA(vC, 1) = ws.Cells(vN, 1)
            vA(vC, 2) = ws.Cells(vN, 2)
            vA(vC, 3) = ws.Cells(vN, 3)
            vA(vC, 4) = ws.Cells(vN, 4)
            vA(vC, 5) = ws.Cells(vN, 5)
            vA(vC, 6) = ws.Cells(vN, 6)
            vA(vC, 7) = ws.Cells(vN, 7)
            vC = vC + 1
        Next vN
    Next ws
    vC = 0
  
End Sub

Sub MergeAndSumUnique()
  
    Dim vD, vAdded As Long, vMR As Long
'create one dimensional array from column "B"
    ReDim vA2(1 To UBound(vA))
    For vN = 1 To UBound(vA)
        vA2(vN) = vA(vN, 2)
    Next vN
'create aray with unique values from column "B"
    With CreateObject("Scripting.Dictionary")
        For Each vD In vA2
            If Not .exists(vD) Then
                .Add vD, .Count
            End If
        Next vD
'create two dimensional array with unique values
        vA2 = Application.Transpose(.keys)
'resize new two dimensional array
        ReDim vA3(1 To .Count, 1 To 7)
    End With
'fill final array
    For vN = 1 To UBound(vA2)
        For vN2 = 1 To UBound(vA)
'but before, compare unique items with items in the column "B"
'if match, sum duplicate values in the column "D"
            If vA2(vN, 1) = vA(vN2, 2) Then
                If vMR = 0 Then vMR = vN2
                vSum = vSum + vA(vN2, 7)
            End If
        Next vN2
        vA3(vN, 1) = vA(vMR, 1)
        vA3(vN, 2) = vA(vMR, 2)
        vA3(vN, 3) = vA(vMR, 3)
        vA3(vN, 4) = vA(vMR, 4)
        vA3(vN, 5) = vA(vMR, 5)
        vA3(vN, 6) = vA(vMR, 6)
        vA3(vN, 7) = vSum
        vSum = 0
        vMR = 0
    Next vN
 
End Sub

Sub OneSheetRows()
  
    vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
    If Not vR = 1 Then
'resize array
        ReDim vA(1 To vR - 1, 1 To 7)
        vC = 1
 'fill array
        For vN = 2 To vR
            vA(vC, 1) = ws.Cells(vN, 1)
            vA(vC, 2) = ws.Cells(vN, 2)
            vA(vC, 3) = ws.Cells(vN, 3)
            vA(vC, 4) = ws.Cells(vN, 4)
            vA(vC, 5) = ws.Cells(vN, 5)
            vA(vC, 6) = ws.Cells(vN, 6)
            vA(vC, 7) = ws.Cells(vN, 7)
            vC = vC + 1
        Next vN
        vC = 0
        Call MergeAndSumUnique
  End If
  
End Sub

Private Sub sh1_Change()
      
    Set ws = Sheets("sh1")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
  
End Sub

Private Sub fgj1_Change()
  
    Set ws = Sheets("fgj1")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
  
End Sub

Private Sub zxc_Change()

    Set ws = Sheets("zxc")
    Call OneSheetRows
    ListBox1.List() = vA3
    If vR = 1 Then ListBox1.Clear
  
End Sub
 
Last edited:
Upvote 0
About setting listbox column widths on userform load.
Add one (help) label control on the userform , and use this...
VBA Code: 
Private Sub UserForm_Initialize()

     Call SetListBoxColumnWidths
    
End Sub

Sub SetListBoxColumnWidths()
   
'don't forget to add label on the userform
    Dim vMaxWidth  As Long, vW As String
   
    With Label1
 'copy some listbox properties to label properties
        .FontSize = ListBox1.FontSize
        .Font.Bold = ListBox1.Font.Bold
 'set label to autosize mode
        .AutoSize = True
 'make label to be in one line
        .WordWrap = False
 'optional, hide label
        .Top = -100
    End With
 'loop through listbox items
    With ListBox1
        For vN = 0 To .ColumnCount - 1
            For vN2 = 0 To .ListCount - 1
 'use label to calculate max width
                Label1.Caption = .List(vN2, vN)
 'keep max width
                If Label1.Width > vMaxWidth Then _
                    vMaxWidth = Label1.Width
            Next vN2
        Next
'set max width to each column
        For vN = 1 To .ColumnCount
            vW = vW & vMaxWidth + 10 & ","
        Next vN
' trim ColumnWidths and display...
        .ColumnWidths = Left(vW, Len(vW) - 1)
    End With

End Sub
About invoice numbers...
VBA Code: 
Sub MergeAndSumUnique()

    Dim vD, vMR As Long
'create one dimensional array from column "B"
    ReDim vA2(1 To UBound(vA))
    For vN = 1 To UBound(vA)
        vA2(vN) = vA(vN, 2)
    Next vN
'create aray with unique values from column "B"
    With CreateObject("Scripting.Dictionary")
        For Each vD In vA2
            If Not .exists(vD) Then
                .Add vD, .Count
            End If
        Next vD
'create two dimensional array with unique values
        vA2 = Application.Transpose(.keys)
'resize new two dimensional array
        ReDim vA3(1 To .Count, 1 To 7)
    End With
'fill final array
    For vN = 1 To UBound(vA2)
        For vN2 = 1 To UBound(vA)
'but before, compare unique items with items in the column "B"
'if match, sum duplicate values in the column "D"
            If vA2(vN, 1) = vA(vN2, 2) Then
                If vMR = 0 Then vMR = vN2
                vSum = vSum + vA(vN2, 7)
'separating text from number
                vInv = Split(vA(vN2, 5), "-")(0)
                vNInv = Split(vA(vN2, 5), "-")(1)
'create string from numbers
                vS = vS & vNInv & ","
            End If
        Next vN2
'edit final string
        vS = vInv & "-" & Left(vS, Len(vS) - 1)
        vA3(vN, 1) = vA(vMR, 1)
        vA3(vN, 2) = vA(vMR, 2)
        vA3(vN, 3) = vA(vMR, 3)
        vA3(vN, 4) = vA(vMR, 4)
'display new string
        vA3(vN, 5) = vS
        vA3(vN, 6) = vA(vMR, 6)
        vA3(vN, 7) = vSum
        vSum = 0
        vMR = 0
        vS = ""
    Next vN

End Sub
 
Upvote 0
thanks
it gives erorr in this line
VBA Code: 
 .ColumnWidths = Left(vW, Len(vW) - 1)
1.PNG
 
Upvote 0
Hasson said:
about the width columns if there is way when I run userform should adjust the columns with columns and make smilir spaces among the columns without use combobox or spin button like this 60;60;120 .... but I no know how do this
Click to expand...
You can set the column width like this (e.g for 3 column listbox):
VBA Code: 
Private Sub UserForm_Initialize()
ListBox1.ColumnWidths = "110,160,80"
End Sub
 
Upvote 0
@Akuini thanks for your sharing . actually I used your way . the problem is in COL3,4 are too close for for each of other I use many values but not succeed . the rest of columns work well.
 
Upvote 0
Insert message box below this loop and tell me what is displayed.
VBA Code: 
'set max width to each column
 For vN = 1 To .ColumnCount
            vW = vW & vMaxWidth + 10 & ","
 Next vN
 MsgBox vW
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Vba combobox- date format
Replies
1
Views
474
DanteAmor
DanteAmor
A
  • Question
updating code selected items based enter a new or change data
Replies
0
Views
309
abdelfattah
A
C
  • Question
Changing the Rowsource of a userform Listbox with each change in the Listbox selection
Replies
0
Views
245
chazrab
C
P
  • Question
Data not copying fully into ListBox2
Replies
0
Views
90
Patriot2879
P
C
  • Question
Getting the cell address of a sheet cell from the Change Event of a Listbox1's code n = Listbox1.Listindex
Replies
5
Views
281
Legacy 143009
L

Forum statistics

Threads
1,214,651
Messages
6,120,744
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top