设置ListBox宽度等于列宽的任何更好方法

Question

我编写了以下代码。因为我是vba的新手。我可以获取小版本或替代代码来实现相同的结果。我想使用工作表列使用的单元格最大长度自动调整列宽的大小。我使用字典方法在列中存储单元格的最大长度，并循环所有列并将最大长度存储到字典中。

'============Refresh ListBox===================
Public Function RefreshData()

Dim max As Integer
Dim Letter As String
Dim RngAddress As String
Dim C As Integer

'enable microsoft scripting runtime from tools ---> reference

Dim mydictionery As Scripting.Dictionary
Set mydictionery = New Scripting.Dictionary

C = 1
max = 0
Letter = "A"

For i = 1 To 26

RngAddress = Letter & 2 & ":" & Letter & 3

For Each cell In Range(RngAddress)
If Len(cell) > max Then max = Len(cell)
Next

mydictionery.Add Letter & max, 0 'add Letter & max to prevent duplicate key

max = 0 'reset max for next range
C = C + 1 'increase counter for dictionery
Letter = Chr(Asc(Letter) + 1) 'next column for range

Next i

Dim iRow As Long
Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Database")
Last_Row = Application.WorksheetFunction.CountA(sh.Range("AB:AB"))

        With DataEntryFormDynamic.ListBox1


        .ColumnCount = 28
        .ColumnHeads = True

        .ColumnWidths = Mid(mydictionery.Keys(0), 2, 15) * 6 & "," & Mid(mydictionery.Keys(1), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(2), 2, 15) * 6 & "," & Mid(mydictionery.Keys(3), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(4), 2, 15) * 6 & "," & Mid(mydictionery.Keys(5), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(6), 2, 15) * 6 & "," & Mid(mydictionery.Keys(7), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(8), 2, 15) * 6 & "," & Mid(mydictionery.Keys(9), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(10), 2, 15) * 6 & "," & Mid(mydictionery.Keys(11), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(12), 2, 15) * 6 & "," & Mid(mydictionery.Keys(12), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(14), 2, 15) * 6 & "," & Mid(mydictionery.Keys(15), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(16), 2, 15) * 6 & "," & Mid(mydictionery.Keys(17), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(18), 2, 15) * 6 & "," & Mid(mydictionery.Keys(19), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(20), 2, 15) * 6 & "," & Mid(mydictionery.Keys(21), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(22), 2, 15) * 6 & "," & Mid(mydictionery.Keys(23), 2, 15) * 6 & "," _
                      & Mid(mydictionery.Keys(24), 2, 15) * 6 & "," & Mid(mydictionery.Keys(25), 2, 15) * 6 & ","

        If Last_Row = 1 Then
        .RowSource = "Database!A2:AB2"
        Else
        .RowSource = "Database!A2:AB" & Last_Row
        End If
        End With

Set mydictionery = Nothing
End Function


'in userform

Private Sub userform activate ()
Call RefreshData
end sub

在此先感谢您的帮助和支持。

Answer 1

这里是一种选择：

Private Sub UserForm_Activate()
    RefreshData
End Sub

Public Function RefreshData()
    Dim sh As Worksheet, lRow As Long, rng As Range

    Set sh = ThisWorkbook.Sheets("Database")
    lRow = Application.max(sh.Cells(Rows.Count, "AB").End(xlUp).Row, 2)
    Set rng = sh.Range("A2:AB" & lRow)

    With Me.ListBox1
        .ColumnCount = 28
        .ColumnHeads = True
        .ColumnWidths = ColWidths(rng.Resize(2, rng.Columns.Count)) 'just using first 2 rows?
        .RowSource = "'" & rng.Parent.Name & "'!" & rng.Address()
    End With

End Function

Public Function ColWidths(rng As Range) As String
    Dim col As Range, arr(), i As Long, m
    ReDim arr(0 To rng.Columns.Count - 1)
    Debug.Print UBound(arr) + 1 & " columns"
    For i = 1 To rng.Columns.Count
        m = rng.Parent.Evaluate("=Max(Len(" & rng.Columns(i).Address() & "))")
        If IsError(m) Then m = 1 'or some other suitable value on an error
        arr(i - 1) = m * 6
    Next i
    Debug.Print Join(arr, ",")
    ColWidths = Join(arr, ",")
End Function

Answer 2

每列的宽度放入一个数组中，并使其成为单个字符，并应用于列表框。

   Private Sub UserForm_Initialize()
        Dim rngDB As Range, rng As Range
        Dim sWidth As String
        Dim vR() As Variant
        Dim n As Integer

        Set rngDB = Range("a1:ab1")
        For Each rng In rngDB
            n = n + 1
            ReDim Preserve vR(1 To n)
            vR(n) = rng.EntireColumn.Width
        Next rng
        sWidth = Join(vR, ";")
        Debug.Print sWidth
        With ListBox1
            .ColumnCount = 28
            .ColumnWidths = sWidth '<~~ 24;24;24;24;24;39;39;39;39;45;45;45;45;45;45;45;45;45;45;45;51;51;51;51;57;57;57;63
            .RowSource = "A1:AB2"
            .BorderStyle = fmBorderStyleSingle
        End With
    End Sub

-调整为最大尺寸

Private Sub UserForm_Initialize()
    Dim rngDB As Range, rng As Range
    Dim sWidth As String
    Dim vR() As Variant
    Dim n As Integer
    Dim myMax As Single

    Set rngDB = Range("a1:ab1")
    For Each rng In rngDB
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = rng.EntireColumn.Width
    Next rng
    myMax = WorksheetFunction.Max(vR)
    For i = 1 To n
        vR(i) = myMax
    Next i

    sWidth = Join(vR, ";")
    Debug.Print sWidth
    With ListBox1
        .ColumnCount = 28
        .ColumnWidths = sWidth '<~~ 63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63
        .RowSource = "A1:AB2"
        .BorderStyle = fmBorderStyleSingle
    End With
End Sub

图像