Function to autosize Listbox and Combobox Columns and optionally the control's width itself.
VBA Code:
Function ControlsResizeColumns(LBox As MSForms.Control, Optional ResizeListbox As Boolean)
Application.ScreenUpdating = False
Dim ws As Worksheet
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 = UserForm1.ListBox1.Font.Name
rng.Characters.Font.Size = UserForm1.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 + 10 '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
Hi, @
alexofrhodes, I know this post is a few years old, but I just came across it and have used it in a project I'm working on. For the most part, the code works fine, but I've got a couple of questions.
I copied your code almost exactly. The only changes I made were (a) removing the optional resize of the listbox; (b) removing the border style; and (c) replacing 'UserForm1.ListBox1' with 'frmNewStudentReg.lstDatabase'. In the Sub, I have the code line 'Call ControlsResizeColumns(lstDatabase)'.
First, the column width setting doesn't seem to take into account the header row:
Notice that the headers for columns 1 (Index), 3 (Microsoft), 4 (Headway), 5 (Leerlingnummer), 6 (Gesprekdatum), and 9 (Instapjaar) are all cut off. (And this happens also for a number of other columns in the database.) The headers are in the worksheet 'Database' in row 1. Any idea why it's not considering the lengths of the headers when setting the column widths?
Second, after around 10 or so columns, I notice that the alignment starts going off, and it gets progressively worse as it goes along:
Notice that the first character of 'GSM-nummerLL' is just under the column line, and by the time it gets to 'PostCd', the first character is left of the column line. By the end of the database:
You can see that the first character starts well before the column line. The first 'trein', for example, should be under the first 'Vervoer' heading, but it's entirely under the previous header. 'Moeder, vader' should be under the column 'Ophalen', and the email addresses should be under the column 'SI Email'. Any idea why this is happening and how to fix it?
Thanks!
Cheers,
Tyler
