Listboxes: synchronise 2 Listbox horizontal scrolling

[Desantech]

Hello

I have 2 listboxes with many columns. Both listboxes are perfectly alligned, same column width in both listboxes.
Upper listbox ist for the column row, the underneath one for the data (I use list.) cos of arrays, and not rowsource, couldnt solve it , because it picks the data dynamically,doesnt matter
.
Now, if the horizontal scrollbar appears in the lower listbox (because of the columns) I would like to move the upper listbox by scrolling the underneath one 1:1

is this possible?
(on the pic the upper on is not yet aligned to the below one)
Thank you much

 

[Batbloke]

Hi,
Just looking at your columns of data in the lower listbox, it appears you could reduce the width of some of your columns. If you done this sufficiently, the horizontal scroll bar would disappear.
You would also need to match the column widths in your upper listbox to match, of course. If you can do this, it would be the simplest solution.
Set the column widths in the properties window, separate each column width with a comma - you do not have to type "pts" after each entry, Excel will do this automatically.
Hope this helps

 

[JEC]

Just include the headers in the data listbox as well. You don't need the upper listbox (just for headers)

 

[JEC]

When the headerdata starts in A1:

This is how you load it

Private Sub UserForm_Initialize()
 With ListBox1
   .ColumnCount = 4         'adapt
   .ColumnHeads = True
   .RowSource = Sheets(1).Cells(1).CurrentRegion.Offset(1).Address         
 End With
End Sub

 

[Batbloke]

.ColumnHeads = True
Jeez how many years have I missed this one, duh - I'm getting old

 

[Desantech]

Hello and thank you , unfortunately I need the upper listbox becuase the listbox data is dynamic (not rowsource) because of arrays. The column width changes automatically according to the cell widths what it captures, so each time new data comes in, it will fit to it, as also the upper listbox, where below listbox ist from a listobject bodyrange, the upper the headerrow. If you tick the checkboxes it will diplay those columns only. Its quite complex.
But if there is no solution for controlling both listboxes by moving 1 listbox horizontal scroller, its not a problem
(btw the automatic resize colums script is copied from a thread here or elsewhere, does its job very nice)
Thanks again

Function ControlsResizeColumns(LBox As MSForms.Control, Optional ResizeListbox As Boolean)
 Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim i As Integer
    If sheetExists("ListboxColumnWidth", ThisWorkbook) = False Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = "ListboxColumnwidth"
    Else
        Set ws = ThisWorkbook.Worksheets("ListboxColumnwidth")
        ws.Cells.Clear
    End If
    '---Listbox/Combobox to range-----
    Dim rng As Range
    Set rng = ThisWorkbook.Sheets("ListboxColumnwidth").Range("A1")
    Set rng = rng.Resize(UBound(LBox.List) + 1, LBox.ColumnCount)
    rng = LBox.List
    rng.Characters.Font.Name = Artikelsuche2.ListBox1.Font.Name
    rng.Characters.Font.Size = Artikelsuche2.ListBox1.Font.Size
    rng.Columns.AutoFit
   
    '---Get ColumnWidths------
    rng.Columns.AutoFit
    Dim sWidth As String
    Dim vR() As Variant
    Dim n As Integer
    Dim cell As Range
    For Each cell In rng.Resize(1)
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = cell.EntireColumn.Width + 20 'if not some extra space it cuts a bit off the tail
    Next cell
    sWidth = Join(vR, ";")
    Debug.Print sWidth

    '---assign ColumnWidths----
    With LBox
        .ColumnWidths = sWidth
        '.RowSource = "A1:A3"
        .BorderStyle = fmBorderStyleSingle
    End With

   
    '----Optionaly Resize Listbox/Combobox--------
    If ResizeListbox = True Then
        Dim w As Long
        For i = LBound(vR) To UBound(vR)
            w = w + vR(i)
        Next
        DoEvents
        LBox.Width = w + 10
    End If
       
    'remove worksheet
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
End Function

Function sheetExists(sheetToFind As String, Optional InWorkbook As Workbook) As Boolean
    If InWorkbook Is Nothing Then Set InWorkbook = ThisWorkbook
    On Error Resume Next
    sheetExists = Not InWorkbook.Sheets(sheetToFind) Is Nothing
End Function



Private Sub UserForm_Initialize()

Dim z As Integer
Dim alpha() As Variant
Dim beta() As Variant
Dim x As Long
Dim y As Long
Dim i As Integer
Dim a As Variant

Dim myarray3() As Variant

'_________________________________________________________________ SETUP CHECKBOXES (checkbox names are Checkbox1 to Checkbox11)


Set a = Sheets("Einstellungen_Asuche")

' On Userform "Artikelsuche2" I have 11 Checkboxes, and according to the values on sheet "a" Range M2:M12, I set the Checkboxes to true or false (there are the values stored)

With Artikelsuche2
    For i = 1 To 11
        .Controls("Checkbox" & i) = a.Range("M" & i + 1).Value
    Next i
End With
                       
' I set a counter "z" to see how many on the sheet "a" range "M+i" are true (I will get rid of this later on)

z = 1

For i = 1 To 11
    If a.Range("M" & i + 1).Value = True Then
        z = z + 1
    End If
Next i

' I correct the value because of i, z show me how many are truely TRUE

z = z - 1

'_________________________________________________________________ How many Columns to be shown in the listbox

' I set Listbox1 Columncount to number of "z" on Userform Artikelsuche2 (?)
    Artikelsuche2.ListBox1.ColumnCount = z
    Artikelsuche2.ListBox2.ColumnCount = z
   
'' I set a static pt width of each column (?)
 '   Artikelsuche2.ListBox1.ColumnWidths = "100"
  '      Artikelsuche2.ListBox2.ColumnWidths = "100"

' I give a name "myTable" to the Listobject found on sheet "Artikelsuche_Temp" called "myTable_Source") I guess needed for textbox script
   
    Set myTable = Worksheets("ArtikelSuche_Temp").ListObjects("myTable_Source")
    myArray = myTable.DataBodyRange

            ReDim beta(0 To 11)
            ReDim alpha(0 To 11)

            For i = 1 To 11

                If a.Range("M" & i + 1).Value = True Then
                    alpha(x) = i + 1
                    beta(y) = i + 1
                x = x + 1
                y = y + 1
            End If
            Next i

    myarray2 = myTable.DataBodyRange.Value2
    myarray2 = Application.Index(myarray2, Evaluate("ROW(1:" & UBound(myarray2) & ")"), Array(alpha(0), alpha(1), alpha(2), alpha(3), alpha(4), alpha(5), alpha(6), alpha(7), alpha(8), alpha(9), alpha(10), alpha(11)))
   

    myarray3 = myTable.HeaderRowRange.Value2
    myarray3 = Application.Index(myarray3, Evaluate("ROW(1:" & 5 & ")"), Array(beta(0), beta(1), beta(2), beta(3), beta(4), beta(5), beta(6), beta(7), beta(8), beta(9), beta(10), beta(11)))
   
    
    Artikelsuche2.ListBox1.List = myarray2
    Artikelsuche2.ListBox2.List = myarray3
   
   
'------------------------------------With rowsource (experiment)
   
   
    'Artikelsuche2.ListBox1.ColumnHeads = True
   
    Dim intStartRow As Integer, intStartCol As Integer
    Dim oWorksheet As Worksheet
    Dim rngCopyTo As Range
    Dim rowsource_temp As Range
    Dim rowsource_temp1 As String
    Set oWorksheet = ActiveWorkbook.Worksheets("AS_T1")

    Dim intEndRow As Integer
    Dim intEndCol As Integer
    intEndRow = UBound(myarray2, 1)
    intEndCol = z

    Set rngCopyTo = oWorksheet.Range(oWorksheet.Cells(1, 1), oWorksheet.Cells(intEndRow, intEndCol))
    rngCopyTo.Value = myarray2
   
    rowsource_temp1 = rngCopyTo.Offset(1, 0).Address

    'ListBox1.RowSource = Sheets("AS_T1").Name & "!" & Range(rowsource_temp1).Address
   
      
'---------------------------------------------------- end row source (not affecting the listboxes)

    Artikelsuche2.TextBox1.Text = Trim(ArtikelSuche.TextBox3.Text)
    Artikelsuche2.TextBox1.SetFocus
   
    Call ControlsResizeColumns(Artikelsuche2.ListBox1)
       
    'Dim e
    'Dim g
    'Dim cnt1 As Integer
    'cnt1 = 0
   
        'For Each e In Split(Artikelsuche2.ListBox1.ColumnWidths, ";")
        'cnt1 = cnt1 + 1
        'With Artikelsuche2
        'g = Left(Right(e, Len(e)), Len(e) - 3)
        '.Controls("Label" & cnt1).Width = Left(Right(e, Len(e)), Len(e) - 3)
        'End With
          '  Debug.Print g
       ' Next e
   
End Sub