Expand column width automatically based on drop down selection

S

Shadkng

Active Member
Joined
Oct 11, 2018
Messages
365
I'm having trouble finding code online that works to autofit a column width based on a selection in a drop down list. I would also like to have a minimum width that the column won't go below. I would need it for many columns in the same sheet so could it be a global type code? If not I can specify the column ranges and that would work. I am using combo drop downs as well if that matters. Thanks
 
Sort by date Sort by votes
Hi, I'm not totally clear, but here is all the code in this particular sheet. I'm not sure of the top left cell - how do I find that out? I know the combobox sits up there but I tried to find it once and couldn't. I'm still new to VBA and much of the code I have was with a lot of help. Thanks

Code: 
Private Sub Worksheet_BeforeDoubleClick _
  (ByVal Target As Range, _
    Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("QuoteCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains
      'a data validation list
    Cancel = True
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    'open the drop down list automatically
    Me.QuoteCombo.DropDown
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'=========================================
Private Sub QuoteCombo_LostFocus()
  With Me.QuoteCombo
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
' ZVI:2019-02-07 https://www.mrexcel.com/forum/excel-questions/1086525-expand-column-width-automatically-based-drop-down-selection.html
 
  '--> Settings, change to suit
  Const FitColumns = "C:D"  ' Columns to fit
  Const FirstDataRow = 24   ' Fit data are in that row and the below rows
  '<--End of the settings
 
  Dim a() As Variant, Col As Range, OldWidth
 
  Application.EnableEvents = False
  Application.ScreenUpdating = False
 
  With Intersect(Target.EntireColumn, Me.Range(FitColumns))
    For Each Col In .Columns
      With Col.Resize(FirstDataRow - Col.Cells(1).Row)
        a() = .Value
        .Value = Empty
        OldWidth = .ColumnWidth
        .EntireColumn.AutoFit
        If .ColumnWidth < OldWidth Then
          .ColumnWidth = OldWidth
        End If
        .Value = a()
      End With
    Next
  End With
 
  Application.EnableEvents = True
  Application.ScreenUpdating = True
 
End Sub
Sub quotecombo_Change()
  ' Code for ComboBox1 ActiveX
  Worksheet_Change Me.QuoteCombo.TopLeftCell.EntireColumn
End Sub
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Good code!
Here is more safety version of the Worksheet_Change, use it instead of the previous one:
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
 
  '--> Settings, change to suit
  Const FitColumns = "C:D"  ' Columns to fit
  Const FirstDataRow = 24   ' Fit data are in that row and the below rows
  '<--End of the settings
 
  Dim a() As Variant, Col As Range, OldWidth As Variant, Rng As Range
 
  Set Rng = Intersect(Target.EntireColumn, Me.Range(FitColumns))
  If Rng Is Nothing Then Exit Sub
 
  Application.EnableEvents = False
  Application.ScreenUpdating = False
 
  For Each Col In Rng.Columns
    With Col.Resize(FirstDataRow - Col.Cells(1).Row)
      a() = .Value
      .Value = Empty
      OldWidth = .ColumnWidth
      .EntireColumn.AutoFit
      If .ColumnWidth < OldWidth Then
        .ColumnWidth = OldWidth
      End If
      .Value = a()
    End With
  Next
 
  Application.EnableEvents = True
  Application.ScreenUpdating = True
 
End Sub
 
Upvote 0
My Aswer Is This said:
... Are you saying by just double clicking on a ActiveX combobox
This will result in creating a Module Script? Which is not a Private script.
I tried this and it does not do that. ...​
Click to expand...

I meant, that in Design mode, which can be set via the toolbar button of VBE or via Ribbon's Developer tab, a double clicking on ActiveX (which is already placed on a Sheet) will create a template code for Change event of that ActiveX. That code will be selected in the sheet's module.
And yes - code by default uses Private statement. But you may delete Private statement from that code to get Sub ComboBox1_Change() which works as expected. But now you can also see and run it in the Alt-F8 macros dialog.​
 
Last edited:
Upvote 0
Hi, OK we're making progress...seems to be working better. A couple of other changes...

Can we have the column go back to the default size if we change the wide entry back to a narrow entry?

Is it possible for a cell that is not a drop down list to autofit when just typing text into the cell? So col C:D may be drop down and E just a regular cell.

I have 2 scripts called worksheet_change. Can I rename one of them? I assume you still need the "_change" part after the new name.
 
Upvote 0
Shadkng said:
1. Can we have the column go back to the default size if we change the wide entry back to a narrow entry?
2. Is it possible for a cell that is not a drop down list to autofit when just typing text into the cell? So col C:D may be drop down and E just a regular cell.
3. I have 2 scripts called worksheet_change. Can I rename one of them? I assume you still need the "_change" part after the new name.
Click to expand...
1. It's possible via a code but by what event? Do you mean change event or clicking special button?
2. Sure, use Const FitColumns = "C:E" or even Const FitColumns = "A:ZZ".
3. Just rename one to Private Sub Worksheet_Change1(ByVal Target As Range) and call it from another one using this line of the code:
Call Worksheet_Change1(Target), like this:
Rich (BB code): 
Private Sub Worksheet_Change1(ByVal Target As Range)
  ' ... The code1 ...
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
  ' ... The code2 ...
  Call Worksheet_Change1(Target)
End Sub
 
Last edited:
Upvote 0
Shadkng said:
Hi, I just realized that both codes #8 and #13 work with my regular data validation drop down lists, however I am using combo drop downs as well and it doesn't work when I use the combo. Any solution for that?
Click to expand...

Could you explain what you're trying to do? step by step.

I'm guessing something like this:

Say you want to insert data in cell A24, you use use a combobox, select an item then tranfer the item/value to the cell, & you want the cell column to be autofit.
Is that correct?
What code do you use to transfer the item/value to the cell?
 
Upvote 0
ZVI said:
1. It's possible via a code but by what event? Do you mean change event or clicking special button?
2. Sure, use Const FitColumns = "C:E" or even Const FitColumns = "A:ZZ".
3. Just rename one to Private Sub Worksheet_Change1(ByVal Target As Range) and call it from another one using this line of the code:
Call Worksheet_Change1(Target), like this:
Rich (BB code): 
Private Sub Worksheet_Change1(ByVal Target As Range)
  ' ... The code1 ...
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
  ' ... The code2 ...
  Call Worksheet_Change1(Target)
End Sub
Click to expand...

In regards to question 1, I mean if I choose a wide entry from the drop down list the column will autofit as it should. Then if I then choose another selection from the same drop down and it is a narrow entry then the column stays wide from the previous selection, it does not size down. I think I mean by a change event as well.

Answer for question 3, I'm not so clear. I cannot rename a change event name? I know what "call" means but I don't understand it in this context.
 
Upvote 0
Akuini said:
Could you explain what you're trying to do? step by step.

I'm guessing something like this:

Say you want to insert data in cell A24, you use use a combobox, select an item then tranfer the item/value to the cell, & you want the cell column to be autofit.
Is that correct?
What code do you use to transfer the item/value to the cell?
Click to expand...

Hi, I would like to have the column autofit from row 24 and down in a specified range. We can use 1000 rows down for now. The autofit should happen instantly when an entry from a data validation box is chosen. I am using activex combo box drop down list so the autofit needs to work with that as well. I would like the column to have a minimum width that it won't fall below. Also, once a column is made wider by an entry, I would like it to reduce if another small entry is chosen. To answer your last question, I am not using any code to transfer the value, only the drop down list.
 
Upvote 0
Shadkng said:
Hi, I would like to have the column autofit from row 24 and down in a specified range. We can use 1000 rows down for now. The autofit should happen instantly when an entry from a data validation box is chosen. I am using activex combo box drop down list so the autofit needs to work with that as well. I would like the column to have a minimum width that it won't fall below. Also, once a column is made wider by an entry, I would like it to reduce if another small entry is chosen. To answer your last question, I am not using any code to transfer the value, only the drop down list.
Click to expand...

Ok, try this:


Code: 
[FONT=lucida console]

[COLOR=Royalblue]Private[/COLOR] [COLOR=Royalblue]Sub[/COLOR] quotecombo_Change()
ActiveCell = quotecombo.Value

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR]

[COLOR=Royalblue]Private[/COLOR] [COLOR=Royalblue]Sub[/COLOR] Worksheet_BeforeDoubleClick([COLOR=Royalblue]ByVal[/COLOR] Target [COLOR=Royalblue]As[/COLOR] Range, Cancel [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Boolean[/COLOR])
[COLOR=Royalblue]Dim[/COLOR] str [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] cboTemp [COLOR=Royalblue]As[/COLOR] OLEObject
[COLOR=Royalblue]Dim[/COLOR] ws [COLOR=Royalblue]As[/COLOR] Worksheet
[COLOR=Royalblue]Set[/COLOR] ws = ActiveSheet
    [COLOR=Royalblue]If[/COLOR] [COLOR=Royalblue]Not[/COLOR] Intersect(Target, Range([COLOR=brown]"A1:A100"[/COLOR])) [COLOR=Royalblue]Is[/COLOR] [COLOR=Royalblue]Nothing[/COLOR] [COLOR=Royalblue]Then[/COLOR]
    [COLOR=Royalblue]Dim[/COLOR] r [COLOR=Royalblue]As[/COLOR] Range
    [COLOR=Royalblue]Set[/COLOR] r = ActiveCell
    [COLOR=Royalblue]Set[/COLOR] cboTemp = ws.OLEObjects([COLOR=brown]" quotecombo"[/COLOR])
      [COLOR=Royalblue]On[/COLOR] [COLOR=Royalblue]Error[/COLOR] [COLOR=Royalblue]Resume[/COLOR] [COLOR=Royalblue]Next[/COLOR]
      [COLOR=Royalblue]With[/COLOR] cboTemp
      [I][COLOR=seagreen]'clear and hide the combo box[/COLOR][/I]
        .ListFillRange = [COLOR=brown]""[/COLOR]
        .LinkedCell = [COLOR=brown]""[/COLOR]
        .Visible = [COLOR=Royalblue]False[/COLOR]
      [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]

        [COLOR=Royalblue]On[/COLOR] [COLOR=Royalblue]Error[/COLOR] [COLOR=Royalblue]GoTo[/COLOR] errHandler
    [COLOR=Royalblue]If[/COLOR] Target.Validation.Type = [COLOR=crimson]3[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        [I][COLOR=seagreen]'if the cell contains[/COLOR][/I]
          [I][COLOR=seagreen]'a data validation list[/COLOR][/I]
        Cancel = [COLOR=Royalblue]True[/COLOR]
        Application.EnableEvents = [COLOR=Royalblue]False[/COLOR]
        [I][COLOR=seagreen]'get the data validation formula[/COLOR][/I]
        str = Target.Validation.Formula1
        str = Right(str, Len(str) - [COLOR=crimson]1[/COLOR])
            [COLOR=Royalblue]With[/COLOR] cboTemp
              [I][COLOR=seagreen]'show the combobox with the list[/COLOR][/I]
              .Visible = [COLOR=Royalblue]True[/COLOR]
              .Left = Target.Left
              .Top = Target.Top
              .Width = [COLOR=crimson]150[/COLOR] [I][COLOR=seagreen]'Target.Width + 5[/COLOR][/I]
              .Height = Target.Height + [COLOR=crimson]5[/COLOR]
              .ListFillRange = str
    [I][COLOR=seagreen]'          .LinkedCell = Target.Address[/COLOR][/I]
            [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
        cboTemp.Activate
        [I][COLOR=seagreen]'open the drop down list automatically[/COLOR][/I]
    [I][COLOR=seagreen]'    cboTemp.DropDown[/COLOR][/I]
     [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
 [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
errHandler:
  Application.EnableEvents = [COLOR=Royalblue]True[/COLOR]
[I][COLOR=seagreen]'  Exit Sub[/COLOR][/I]

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR]

[I][COLOR=seagreen]'=========================================[/COLOR][/I]
[COLOR=Royalblue]Private[/COLOR] [COLOR=Royalblue]Sub[/COLOR] quotecombo_LostFocus()
  [COLOR=Royalblue]With[/COLOR] Me.quotecombo
    .Visible = [COLOR=Royalblue]False[/COLOR]
    .Value = [COLOR=brown]""[/COLOR]
  [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR]


[COLOR=Royalblue]Private[/COLOR] [COLOR=Royalblue]Sub[/COLOR] Worksheet_Change([COLOR=Royalblue]ByVal[/COLOR] Target [COLOR=Royalblue]As[/COLOR] Range)
        [I][COLOR=seagreen]'change the range address to suit[/COLOR][/I]
    [COLOR=Royalblue]If[/COLOR] [COLOR=Royalblue]Not[/COLOR] Intersect(Target, Range([COLOR=brown]"A24:B1000,D24:E1000"[/COLOR])) [COLOR=Royalblue]Is[/COLOR] [COLOR=Royalblue]Nothing[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        [COLOR=Royalblue]Dim[/COLOR] x [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Double[/COLOR]
        [COLOR=Royalblue]If[/COLOR] Target.Cells.Count = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]Then[/COLOR]
[I][COLOR=seagreen]'            x = Target.Columns.ColumnWidth[/COLOR][/I]
            Target.Columns.AutoFit
[I][COLOR=seagreen]'            If Target.Columns.ColumnWidth < x Then Target.Columns.ColumnWidth = x[/COLOR][/I]
            
            [I][COLOR=seagreen]'minimum width, change to suit[/COLOR][/I]
            [COLOR=Royalblue]If[/COLOR] Target.Columns.ColumnWidth < [COLOR=crimson]10[/COLOR] [COLOR=Royalblue]Then[/COLOR] Target.Columns.ColumnWidth = [COLOR=crimson]10[/COLOR]
       
        [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
    [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR]

[/FONT]
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Auto Sort rows based on a selection from a drop down menu
Replies
4
Views
84
Joe4
Joe4
C
  • Question
Dependent Drop Down Help, Excel 2010
Replies
5
Views
197
Akuini
Akuini
T
  • Question
Show different values to drop down box
Replies
1
Views
204
Scott Huish
Scott Huish
C
  • Solved
Column data selection drop-down
Replies
5
Views
327
SanjayGMusafir
SanjayGMusafir
A
  • Solved
Need VBA to automatically copy paste rows based factory selected
Replies
8
Views
203
Alex Blakenburg
A

Forum statistics

Threads
1,215,328
Messages
6,124,299
Members
449,149
Latest member
mwdbActuary

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