Split cell text to another row due to maximum row height

tbhendralesmana · Mar 2nd 2020

Hello all,

Good day, love the new look for the forum.

hope this is not repeated question as I could not find the similar one.

I have an excel with an automated update from SharePoint list, this list provides me data from column A to G (worksheet named as Master Table). The data that I have in column F is generate as text which is most of the time having lot of characters and its turn the cell height become maximum number that excels can provide (409.5) this condition cause a problem that every time I save the file to pdf some of the text is cut and missing from the preview.

is there any VBA code that could split the text in column F whenever the height is maximum so that the rest of the text will go to the next row.

I used the autofit function but it is not enough to cover the needs,

can someone help me out?

here is my code with autofit :

Code

Sub CallMacros()
ActiveWorkbook.Unprotect "XXX"
Application.ScreenUpdating = False
Dim User As String
Dim PdfFile As String
Dim strFile As String
Dim strPath As String
ThisWorkbook.RefreshAll
Application.CalculateFull
'PDF Report Export
ThisWorkbook.Sheets("Master Table").Visible = True
ThisWorkbook.Sheets("Master Table").Select
Range("A:G").Select
With Selection.Font
.Name = "Tahoma"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A:G").Font.Size = 10.5
Range("A:G").Font.Name = Tahoma
Worksheets("Master Table").Range("A:G").EntireRow.AutoFit
Worksheets("Master Table").Range("A:G").EntireRow.VerticalAlignment = xlVAlignCenter
Worksheets("Master Table").Range(Columns(10), Columns(10)).EntireColumn.Hidden = True
Worksheets("Master Table").Columns("C").Replace _
What:="TRUE", Replacement:="YES", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Master Table").Columns("C").Replace _
What:="FALSE", Replacement:="NO", _
SearchOrder:=xlByColumns, MatchCase:=True
ThisWorkbook.Sheets("Master Table").Select
Worksheets("Master Table").Cells(1, 1).Select
User = Environ("username")
strFile = Format(Int(Now()) - 3, "DD") & "-" & Format(Int(Now()), "DDMMM") & ", " & "Shift Report " & ".pdf"
strPath = GetDesktop() & "\"
ActiveSheet.PageSetup.CenterHeader = "&""Tahoma,bold""&12" & Chr(10) & Format(Int(Now()) - 3, "DDDD,DD/MMMM/YYYY HH:MM") & " - " & Format(Now(), "DDDD,DD/MMMM/YYYY HH:MM")
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPath & strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = True
Worksheets("Master Table").Range(Columns(10), Columns(10)).EntireColumn.Hidden = False
ActiveSheet.PageSetup.CenterHeader = ""
ActiveSheet.AutoFilter.Sort.SortFields.Clear
MsgBox "XXX Report was saved to your Desktop.", vbInformation
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Application.ScreenUpdating = True
ThisWorkbook.Sheets("Master Table").Visible = xlSheetHidden
ActiveSheet.Protect "XXX"
ActiveWorkbook.Protect "XXX", True, False
Application.ScreenUpdating = True
End Sub

Display More

tbhendralesmana · Mar 5th 2020

up

looking for some advice ...

Justin Doward · Mar 8th 2020

Hello tbh,

Not sure if you have solved this yet?

The approach I would take would be to calculate the number of characters required to fill the cell then use an if len(x) > allowed-characters then cut the text as required. This depends upon the width of the column, for example I just tested a width of 100 and the maximum number of characters I could fit with the height at maximum were 2533 using tahoma 12 pt font.

The code below checks the length of the text in the F2 cell, rounds up the integer and then copies the string over back into the required number of cells ensuring it each does not exceed the maximum number allowed.

If you wanted to be fancy you could search for the nearest full stop to the end in each string using the instrrev, but it would be a more complicated solution (if you were confident it will never require more than 2 cells then finding the full stop closest to the end of the first cell would be easy enough).

Code

Sub divup()
Dim ws As Worksheet: Set ws = Sheets("Master Table")
Dim MyStr, MyNStr As String
Dim x As Long
Dim MyL As Single
MyStr = ws.Cells(2, 6).Value
MyL = Application.RoundUp(Len(MyStr) / 2533, 0)
If MyL > 1 Then
For x = 1 To MyL
MyNStr = Mid(MyStr, 1 + ((x - 1) * 2533), 2533)
ws.Cells(x + 1, 6).Value = MyNStr
Next x
End If
End Sub

Display More

HTH

Justin

Share

Tags