Új hozzászólás Aktív témák

• #49002 lenkei83 tag

  Új Válasz 2022-05-10 21:35:49 #49002

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lenkei83

  tag

  Sziasztok!

  Biztosan már fáradt vagyok... de nem jövök rá, hogyan tudom ezt meghívni Sub-ból.
  Kérem, hogy nézzen rá valaki.

  Köszi
  P.

  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 = formStaffList.listboxStaff.Font.Name
    rng.Characters.Font.Size = formStaffList.listboxStaff.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

Új hozzászólás Aktív témák