Scroll bar if text too big for cell

[rfletcher35]

Hi Guys

I have a routine that populates multiple sheets in multiple pages from one set of data. One these multiple sheets column C on my sheets I would like to keep to a max height of 180.
If the text placed in this column goes over this height then I would like vba to place a scroll bar in the cell. I need it from row 5 to 100.

Is this possible? I have placed where I need the code below

In addition if there is a neat way to abbreviate the below where I try to neaten the worksheet I am open to suggestions.

Thanks

Fletch

Sub PopulateTabs()

Dim lastRow As Long, r As Long

With Worksheets("Stats")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
'Loop through clients in Stats column B from row 3
For r = 3 To lastRow
'Filter Import column F on this client
Worksheets("Import").Range("A1").AutoFilter Field:=6, Criteria1:=.Cells(r, "B").Value
'Stats column M is destination sheet name - clear sheet and copy filtered data to A4
Worksheets(.Cells(r, "M").Value).Cells.ClearContents
Worksheets("Import").UsedRange.SpecialCells(xlCellTypeVisible).Copy
Worksheets(.Cells(r, "M").Value).Range("A4").PasteSpecial
ActiveWindow.Zoom = 90
Format_Sheet Worksheets(.Cells(r, "M").Value)

'ws.Range("A4:A600,E4:E600,G4:G600,J4:J600,L4:L600,N4:AA600,AD4:AD600,AH4:AI600").Delete Shift:=xlToLeft

Worksheets(.Cells(r, "M").Value).Rows("4:4").HorizontalAlignment = xlCenter
Worksheets(.Cells(r, "M").Value).Rows("4:4").VerticalAlignment = xlCenter
Worksheets(.Cells(r, "M").Value).Rows("4:4").WrapText = True
Worksheets(.Cells(r, "M").Value).Rows("4:4").Orientation = 0
Worksheets(.Cells(r, "M").Value).Rows("4:4").AddIndent = False
Worksheets(.Cells(r, "M").Value).Rows("4:4").IndentLevel = 0
Worksheets(.Cells(r, "M").Value).Rows("4:4").ShrinkToFit = False
Worksheets(.Cells(r, "M").Value).Rows("4:4").ReadingOrder = xlContext
Worksheets(.Cells(r, "M").Value).Rows("4:4").MergeCells = False
Worksheets(.Cells(r, "M").Value).Rows("4:4").Font.Bold = True

Worksheets(.Cells(r, "M").Value).Rows("5:100").HorizontalAlignment = xlLeft
Worksheets(.Cells(r, "M").Value).Rows("5:100").VerticalAlignment = xlCenter
Worksheets(.Cells(r, "M").Value).Rows("5:100").WrapText = True
Worksheets(.Cells(r, "M").Value).Rows("5:100").Orientation = 0
Worksheets(.Cells(r, "M").Value).Rows("5:100").AddIndent = False
Worksheets(.Cells(r, "M").Value).Rows("5:100").IndentLevel = 0
Worksheets(.Cells(r, "M").Value).Rows("5:100").ShrinkToFit = False
Worksheets(.Cells(r, "M").Value).Rows("5:100").ReadingOrder = xlContext
Worksheets(.Cells(r, "M").Value).Rows("5:100").MergeCells = False
Worksheets(.Cells(r, "M").Value).Rows("5:100").EntireRow.AutoFit
Worksheets(.Cells(r, "M").Value).Rows("5:100").Font.Size = 9


Worksheets(.Cells(r, "M").Value).Range("A4").FormulaR1C1 = "Autotask Ticket Number"
Worksheets(.Cells(r, "M").Value).Range("B4").FormulaR1C1 = "Title"
Worksheets(.Cells(r, "M").Value).Range("D4").FormulaR1C1 = "Company"
Worksheets(.Cells(r, "M").Value).Range("F4").FormulaR1C1 = "Status"
Worksheets(.Cells(r, "M").Value).Range("G4").FormulaR1C1 = "Source"
Worksheets(.Cells(r, "M").Value).Range("H4").FormulaR1C1 = "Primary Resource"
Worksheets(.Cells(r, "M").Value).Range("L4").FormulaR1C1 = "Due Date/Time"
Worksheets(.Cells(r, "M").Value).Columns("A:A").ColumnWidth = 16
Worksheets(.Cells(r, "M").Value).Columns("C:C").ColumnWidth = 100
Worksheets(.Cells(r, "M").Value).Columns("D:D").ColumnWidth = 15
Worksheets(.Cells(r, "M").Value).Columns("E:E").ColumnWidth = 13
Worksheets(.Cells(r, "M").Value).Columns("F:F").ColumnWidth = 9
Worksheets(.Cells(r, "M").Value).Columns("G:G").ColumnWidth = 8
Worksheets(.Cells(r, "M").Value).Columns("H:H").ColumnWidth = 18
Worksheets(.Cells(r, "M").Value).Columns("I:I").EntireColumn.AutoFit
Worksheets(.Cells(r, "M").Value).Columns("J:J").EntireColumn.AutoFit
Worksheets(.Cells(r, "M").Value).Columns("K:K").EntireColumn.AutoFit
Worksheets(.Cells(r, "M").Value).Columns("L:L").EntireColumn.AutoFit
Worksheets(.Cells(r, "M").Value).Columns("M:M").EntireColumn.AutoFit
Worksheets(.Cells(r, "M").Value).Columns("N:N").ColumnWidth = 16





Next
Worksheets("Import").AutoFilterMode = False
Application.CutCopyMode = False
End With

 

[Dermot]

Cells dont have scrollbars

 

[DanteAmor]

In a cell you cannot put a scrollbar, but you can put an activex textbox control and add the scrollbar.
It would look something like this:

To accomplish the above, do the following:
On each sheet add a textbox1 (Activex Control)

Put in this line the names of the destination sheets.
Case "M3", "M4", "Sheet10", "etc"
If there are many sheets, I could adapt the code to take the names of the sheets from the "stats" sheet. But run some tests.


Add the following code to ThisWorkbook events.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Select Case Sh.Name
    'Name of the sheets that will have the textbox
    Case "M3", "M4", "Sheet10", "etc"
      ActiveSheet.TextBox1.Visible = False
      If Target.CountLarge > 1 Then Exit Sub
      If Not Intersect(Target, Range("C5:C100")) Is Nothing Then
        If Target.Value = "" Then Exit Sub
        With ActiveSheet.TextBox1
          .Visible = True
          .Top = Target.Top
          .Left = Target.Left
          .Value = Target.Value
          .Width = Target.Width
          .Height = 100
          .MultiLine = True
          .ScrollBars = fmScrollBarsVertical
        End With
      End If
  End Select
End Sub

ThisWorkbook EVENT
___________________________________________________________
- Open the VB Editor (press Alt + F11).
- Over in the Project Explorer, double click on ThisWorkbook.
- In the white panel that then appears, paste the above code.

___________________________________________________________

In addition if there is a neat way to abbreviate the below

I made some adjustments:

Sub PopulateTabs()
  Dim r As Long
  Dim shSt As Worksheet
  Dim shIm As Worksheet
  
  Application.ScreenUpdating = False
  
  Set shSt = Sheets("Stats")
  Set shIm = Sheets("Import")
  
  'Loop through clients in Stats column B from row 3
  For r = 3 To shSt.Cells(Rows.Count, "B").End(xlUp).Row
    'Filter Import column F on this client
    shIm.Range("A1").AutoFilter 6, shSt.Cells(r, "B").Value
    'Stats column M is destination sheet name - clear sheet and copy filtered data to A4
    With Sheets(shSt.Cells(r, "M").Value)
      .Cells.ClearContents
      shIm.UsedRange.SpecialCells(xlCellTypeVisible).Copy
      .Range("A4").PasteSpecial
      Call Format_Sheet(.Name)
      'ws.Range("A4:A600,E4:E600,G4:G600,J4:J600,L4:L600,N4:AA600,AD4:AD600,AH4:AI600").Delete Shift:=xlToLeft
      .Rows("4:4").HorizontalAlignment = xlCenter
      .Rows("4:4").Font.Bold = True
      
      .Rows("4:100").HorizontalAlignment = xlLeft
      .Rows("4:100").VerticalAlignment = xlCenter
      .Rows("4:100").WrapText = True
      .Rows("4:100").Orientation = 0
      .Rows("4:100").AddIndent = False
      .Rows("4:100").IndentLevel = 0
      .Rows("4:100").ShrinkToFit = False
      .Rows("4:100").ReadingOrder = xlContext
      .Rows("4:100").MergeCells = False
      
      .Rows("5:100").EntireRow.AutoFit
      .Rows("5:100").Font.Size = 9
      
      .Range("A4").Value = "Autotask Ticket Number"
      .Range("B4").Value = "Title"
      .Range("D4").Value = "Company"
      .Range("F4").Value = "Status"
      .Range("G4").Value = "Source"
      .Range("H4").Value = "Primary Resource"
      .Range("L4").Value = "Due Date/Time"
      
      .Columns("A:A").ColumnWidth = 16
      .Columns("C:C").ColumnWidth = 100
      .Columns("D:D").ColumnWidth = 15
      .Columns("E:E").ColumnWidth = 13
      .Columns("F:F").ColumnWidth = 9
      .Columns("G:G").ColumnWidth = 8
      .Columns("H:H").ColumnWidth = 18
      .Columns("I:M").EntireColumn.AutoFit
      .Columns("N:N").ColumnWidth = 16
    End With
  Next
  shIm.AutoFilterMode = False
  Application.CutCopyMode = False
End Sub

 

[DanteAmor]

In ThisWorkbook events. Correct this line:

If Not Intersect(Target, Range("C5:C100")) Is Nothing Then

For this:
If Not Intersect(Target, Sh.Range("C5:C100")) Is Nothing Then

______________________________________
I put an update to your code:

Sub PopulateTabs()
  Dim r As Long
  Dim shSt As Worksheet, shIm As Worksheet
  Dim cols As Variant, w As Variant
 
  Application.ScreenUpdating = False
 
  Set shSt = Sheets("Stats")
  Set shIm = Sheets("Import")
  cols = Array("A", 16, "C", 100, "D", 15, "E", 13, "F", 9, "G", 8, "H", 19, "N", 16)

  'Loop through clients in Stats column B from row 3
  For r = 3 To shSt.Cells(Rows.Count, "B").End(xlUp).Row
    'Filter Import column F on this client
    shIm.Range("A1").AutoFilter 6, shSt.Cells(r, "B").Value
    'Stats column M is destination sheet name - clear sheet and copy filtered data to A4
    With Sheets(shSt.Cells(r, "M").Value)
      .Cells.ClearContents
      shIm.UsedRange.SpecialCells(xlCellTypeVisible).Copy
      .Range("A4").PasteSpecial
      Call Format_Sheet(.Name)
      'ws.Range("A4:A600,E4:E600,G4:G600,J4:J600,L4:L600,N4:AA600,AD4:AD600,AH4:AI600").Delete Shift:=xlToLeft
      .Rows("4:4").HorizontalAlignment = xlCenter
      .Rows("4:4").Font.Bold = True
     
      .Rows("4:100").HorizontalAlignment = xlLeft
      .Rows("4:100").VerticalAlignment = xlCenter
      .Rows("4:100").WrapText = True
      .Rows("4:100").Orientation = 0
      .Rows("4:100").AddIndent = False
      .Rows("4:100").IndentLevel = 0
      .Rows("4:100").ShrinkToFit = False
      .Rows("4:100").ReadingOrder = xlContext
      .Rows("4:100").MergeCells = False
     
      .Rows("5:100").EntireRow.AutoFit
      .Rows("5:100").Font.Size = 9
     
      .Range("A4,B4,D4,F4,G4,H4,L4").Value = Array("Autotask Ticket Number", "Title", _
        "Company", "Status", "Source", "Primary Resource", "Due Date/Time")
           
      For w = 0 To UBound(cols) Step 2
        .Columns(cols(w)).ColumnWidth = cols(w + 1)
      Next
      .Columns("I:M").EntireColumn.AutoFit
    End With
  Next
  shIm.AutoFilterMode = False
  Application.CutCopyMode = False
End Sub