Macro to adjust line break in a text box

Z

zinah

Active Member
Joined
Nov 28, 2018
Messages
368
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have below macro, what it does:
It count the characters of concerned text and then add a line break whenever the text exceeds the text box size, then add this sentence "[more detail available in System]" in the last line of the text box.
What I'm facing right now is: the text in text box exceeds the text box size and it's not working properly as you can see in below screenshot:

1585499152764.png


Can anyone help me with this issue? Below is the macro, was trying to share a sample file but not sure how.
VBA Code: 
Sub count_characters_per_line_break()
    Set aSht = ActiveSheet
    'Set rSht = Sheets("Role Scorecard")
    'Set rSht = Sheets("ref.")
'rSht.Activate
    Sheets("ref.").Activate
    Sheets("ref.").[N24:V28].ClearContents
    [Pop_ObjRng].ClearContents
    [Pop_OutRng].ClearContents
    [Pop_PrgRng].ClearContents

If Sheets("ref.").[Goals_Count].Value = 0 Then Exit Sub

    Dim gH As Double, gW As Double
        gH = Sheets("Role Scorecard").Shapes("Goal_1_Obj").Height / 72
        gW = Sheets("Role Scorecard").Shapes("Goal_1_Obj").Width / 72

    Dim chLm, lnLm As Double
        chLm = CInt(gW / ((3.06) / 49))
        lnLm = CInt(gH / ((1.29) / 8))
'MsgBox chLm & Chr(10) & lnLm
    
        [I11].Value = gH
        [I12].Value = gW
        [I13].Value = chLm
        [I14].Value = lnLm

'Dim gCnt As Long, g As Long
'    gCnt = Sheets("ref.").[Goals_Count]
'    If gCnt > 5 Then gCnt = 5

Dim o, m, p, obrk, oCnt, oLn, mLn, mbrk, mcnt, pbrk, pCnt, pLn As Integer
Dim i, j, b, s As Integer
    o = [I23].Column     'objective
    m = [K23].Column     'outcome
    p = [H23].Column     'comments/description
    obrk = [N23].Column  'paragraph count
    oCnt = [O23].Column  'character count
    oLn = [P23].Column
    mbrk = [Q23].Column  'paragraph line break
    mcnt = [R23].Column  'character count per paragraph
    mLn = [S23].Column
    pbrk = [T23].Column  'comments paragraph line break
    pCnt = [U23].Column  'character count per paragraph
    pLn = [V23].Column

Dim obj, out, prg, objBrk, objCnt, prgCnt, prgLn, prgBrk, objLn, outLn, outBrk, outCnt As Range
Dim objPop, outPop, prgPop As String
Dim brkCnt As New Collection

OBJECTIVE_LOOP:
Set brkCnt = New Collection
For Each cel In Range("Pop_ObjRng")
    Set obj = Cells(cel.Row, o)
    Set objBrk = Cells(cel.Row, obrk)
    Set objCnt = Cells(cel.Row, oCnt)
    Set objLn = Cells(cel.Row, oLn)
        objBrk.Value = ""
        objCnt.Value = ""
        objLn.Value = ""
        objPop = ""
        
        brkCnt.Add 1
    For ch = 1 To Len(obj)
        If Mid(obj, ch, 1) = Chr(10) Then
            brkCnt.Add ch
        End If
    Next ch
        brkCnt.Add Len(obj)

    For Each itm In brkCnt
        'MsgBox itm
    Next itm
    
        i = 0
        j = 0
        b = 0
        s = 0

    If brkCnt.Count = 2 Then
        i = i + 1
        j = i + 1
        b = b + 1
        
        objBrk.Value = b & " | "
        objCnt.Value = Len(obj) & " | "
        objLn.Value = Application.WorksheetFunction.RoundUp((Len(obj) / chLm), 0)

        If Val(objLn.Value) <= (lnLm - 1) Then
            objPop = Sheets("ref.").Cells(objLn.Row, [I23].Column).Value
        
        Else:
            objPop = Left(Sheets("ref.").Cells(objLn.Row, [I23].Column).Value, (7 * chLm) - 3) & "..." & _
                        Chr(10) & "[more detail available in System]"
            'objPop.TextFrame.Characters(InStr(1, (prglbl & prgTxt), prgTxt), Len(prgTxt)).Font.Color = RGB(0, 0, 255)
        End If
        
    Else:
    Do Until j = brkCnt.Count
        i = i + 1
        j = i + 1
        b = b + 1
        'MsgBox Trim(Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32) & Chr(10) & Len(Trim(Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32)) & " character(s)"
        objBrk.Value = b & " | "
        objCnt.Value = objCnt.Value & Len(Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & " | "
        objLn.Value = Val(objLn.Value) + Application.WorksheetFunction.RoundUp((Len(Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) / chLm), 0)

        If Val(objLn.Value) <= (lnLm - 1) Then
            If b = brkCnt.Count - 1 Then
                objPop = objPop & Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)
            Else:
                objPop = objPop & Mid(obj, brkCnt(i), brkCnt(j) - brkCnt(i))
            End If
            
        ElseIf Val(objLn.Value) >= lnLm And s = 0 Then
            If i - 1 = 0 Then
                objPop = Left(obj, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
                s = 1
                
            ElseIf i - 1 > 0 Then
'    MsgBox "objPop (left option) = " & Left(obj, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]" & Chr(10) & Chr(10) & Chr(10) & _
            "objPop (mid option) = " & Mid(obj, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
            If brkCnt.Count >= 3 And brkCnt.Count <= 5 Then
                objPop = Left(obj, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
            Else:
                objPop = Mid(obj, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
            End If
                s = 1
            End If
        End If
        
    Loop
    End If
    
    
    With objCnt
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    With objBrk
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .IndentLevel = 5
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With

Sheets("ref.").Cells(objLn.Row, [Pop_ObjRng].Column).Value = objPop

NEXT_Obj_cel:
    Set brkCnt = New Collection
    'MsgBox "Completed " & cel.Address(False, False) & Chr(10) & "reset brkCnt Collection.Count to: " & brkCnt.Count
Next cel
    [P22].Value = lnLm - 1


OUTCOME_LOOP:
Set brkCnt = New Collection
For Each cel In Range("Pop_OutRng")
    Set out = Cells(cel.Row, m)
    Set outBrk = Cells(cel.Row, mbrk)
    Set outCnt = Cells(cel.Row, mcnt)
    Set outLn = Cells(cel.Row, mLn)
        outBrk.Value = ""
        outCnt.Value = ""
        outLn.Value = ""
        outPop = ""
        
        brkCnt.Add 1
    For ch = 1 To Len(out)
        If Mid(out, ch, 1) = Chr(10) Then
            brkCnt.Add ch
        End If
    Next ch
        brkCnt.Add Len(out)

    For Each itm In brkCnt
        'MsgBox itm
    Next itm
    
        i = 0
        j = 0
        b = 0
        s = 0
        
    If brkCnt.Count = 2 Then
        i = i + 1
        j = i + 1
        b = b + 1
        
        outBrk.Value = b & " | "
        outCnt.Value = Len(out) & " | "
        outLn.Value = Application.WorksheetFunction.RoundUp((Len(out) / chLm), 0)
        
        If Val(outLn.Value) <= (lnLm - 1) Then
            outPop = Sheets("ref.").Cells(outLn.Row, [K23].Column).Value
        
        Else:
            outPop = Left(Sheets("ref.").Cells(outLn.Row, [K23].Column).Value, (7 * chLm) - 3) & "..." & _
                        Chr(10) & "[more detail available in System]"
            
        
        End If
        
    Else:
'If cel.Row = 26 Then
'    MsgBox _
    "LEN(K26) = " & Len([K26].Value) & Chr(10) & _
    "Application.WorksheetFunction.RoundUp((Len(out) / chLm), 0) = " & Application.WorksheetFunction.RoundUp((Len(out) / chLm), 0)
    
'    MsgBox _
    "LEFT(K26, (7 * " & chLm & ") - 3) = " & Chr(10) & Chr(10) & _
    Left(Sheets("ref.").Cells(outLn.Row, [K22].Column).Value, (7 * chLm) - 3)
'    Exit Sub
'End If

    Do Until j = brkCnt.Count
        i = i + 1
        j = i + 1
        b = b + 1
        'MsgBox Trim(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32) & Chr(10) & Len(Trim(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32)) & " character(s)"
        outBrk.Value = b & " | "
        outCnt.Value = outCnt.Value & Len(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & " | "
        outLn.Value = Val(outLn.Value) + Application.WorksheetFunction.RoundUp((Len(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) / chLm), 0)
        
        If Val(outLn.Value) <= (lnLm - 1) Then
            If b = brkCnt.Count - 1 Then
                outPop = outPop & Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)
            Else:
                outPop = outPop & Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i))
            End If
            
        
        ElseIf Val(outLn.Value) >= lnLm And s = 0 Then
            If i - 1 = 0 Then
        'If cel.Row = 27 Then MsgBox "brkCnt.Count = " & brkCnt.Count & Chr(10) & "b = " & b & Chr(10) & "outLn.Value = " & outLn.Value & Chr(10) & outPop
        'If cel.Row = 27 Then MsgBox "((chLm * lnLm) - Len([more detail available in System]) + 4) = " & (chLm * lnLm) - Len("[more detail available in System]") + 4 & Chr(10) & Chr(10) & _
                                        "out = " & Len(out) & Chr(10) & out
                outPop = Left(out, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
                s = 1
                
            ElseIf i - 1 > 0 Then
'If cel.Row = 27 Then
'    MsgBox "outPop (left option) = " & Left(out, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]" & Chr(10) & Chr(10) & Chr(10) & _
            "outPop (mid option) = " & Mid(out, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
'End If
            If brkCnt.Count >= 3 And brkCnt.Count <= 5 Then
                outPop = Left(out, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
            Else:
                outPop = Mid(out, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
            End If
                s = 1
            End If
        End If
        
    Loop
    End If
        
    With outCnt
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    With outBrk
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .IndentLevel = 5
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
        

Sheets("ref.").Cells(outLn.Row, [Pop_OutRng].Column).Value = outPop


NEXT_Out_cel:
    Set brkCnt = New Collection
    Set brkCnt = Nothing
    'MsgBox "Completed " & cel.Address(False, False) & Chr(10) & "reset brkCnt Collection.Count to: " & brkCnt.Count
Next cel
    [S22] = lnLm - 1

'Zina
COMMENTS_LOOP:  'progress notes
Set brkCnt = New Collection
For Each cel In Range("Pop_PrgRng")
    Set prg = Cells(cel.Row, p)
    Set prgBrk = Cells(cel.Row, pbrk)
    Set prgCnt = Cells(cel.Row, pCnt)
    Set prgLn = Cells(cel.Row, pLn)
        prgBrk.Value = ""
        prgCnt.Value = ""
        prgLn.Value = ""
        prgPop = ""
        
        brkCnt.Add 1
    For ch = 1 To Len(prg)
        If Mid(prg, ch, 1) = Chr(10) Then
            brkCnt.Add ch
        End If
    Next ch
        brkCnt.Add Len(prg)

    For Each itm In brkCnt
        'MsgBox itm
    Next itm
    
        i = 0
        j = 0
        b = 0
        s = 0
        
    If brkCnt.Count = 2 Then
        i = i + 1
        j = i + 1
        b = b + 1
        
        prgBrk.Value = b & " | "
        prgCnt.Value = Len(prg) & " | "
        prgLn.Value = Application.WorksheetFunction.RoundUp((Len(prg) / chLm), 0)
        
        If Val(prgLn.Value) <= (lnLm - 1) Then
            prgPop = Sheets("ref.").Cells(prgLn.Row, [H23].Column).Value
        
        Else:
            prgPop = Left(Sheets("ref.").Cells(prgLn.Row, [H23].Column).Value, (7 * chLm) - 3) & "..." & _
                        Chr(10) & "[more detail available in System]"
            
        
        End If
        
    Else:
'If cel.Row = 26 Then
'    MsgBox _
    "LEN(K26) = " & Len([K26].Value) & Chr(10) & _
    "Application.WorksheetFunction.RoundUp((Len(out) / chLm), 0) = " & Application.WorksheetFunction.RoundUp((Len(out) / chLm), 0)
    
'    MsgBox _
    "LEFT(K26, (7 * " & chLm & ") - 3) = " & Chr(10) & Chr(10) & _
    Left(Sheets("ref.").Cells(outLn.Row, [K22].Column).Value, (7 * chLm) - 3)
'    Exit Sub
'End If

    Do Until j = brkCnt.Count
        i = i + 1
        j = i + 1
        b = b + 1
        'MsgBox Trim(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32) & Chr(10) & Len(Trim(Mid(out, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & Chr(32)) & " character(s)"
        prgBrk.Value = b & " | "
        prgCnt.Value = prgCnt.Value & Len(Mid(prg, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) & " | "
        prgLn.Value = Val(prgLn.Value) + Application.WorksheetFunction.RoundUp((Len(Mid(prg, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)) / chLm), 0)
        
        If Val(prgLn.Value) <= (lnLm - 1) Then
            If b = brkCnt.Count - 1 Then
                prgPop = prgPop & Mid(prg, brkCnt(i), brkCnt(j) - brkCnt(i) + 1)
            Else:
                prgPop = prgPop & Mid(prg, brkCnt(i), brkCnt(j) - brkCnt(i))
            End If
            
        
        ElseIf Val(prgLn.Value) >= lnLm And s = 0 Then
            If i - 1 = 0 Then
        'If cel.Row = 27 Then MsgBox "brkCnt.Count = " & brkCnt.Count & Chr(10) & "b = " & b & Chr(10) & "outLn.Value = " & outLn.Value & Chr(10) & outPop
        'If cel.Row = 27 Then MsgBox "((chLm * lnLm) - Len([more detail available in System]) + 4) = " & (chLm * lnLm) - Len("[more detail available in System]") + 4 & Chr(10) & Chr(10) & _
                                        "out = " & Len(out) & Chr(10) & out
                prgPop = Left(prg, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
                s = 1
                
            ElseIf i - 1 > 0 Then
'If cel.Row = 27 Then
'    MsgBox "outPop (left option) = " & Left(out, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]" & Chr(10) & Chr(10) & Chr(10) & _
            "outPop (mid option) = " & Mid(out, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
'End If
            If brkCnt.Count >= 3 And brkCnt.Count <= 5 Then
                prgPop = Left(prg, (chLm * (lnLm - 2)) - Len("[more detail available in System]") + 4) & "..." & _
                            Chr(10) & "[more detail available in System]"
            Else:
                prgPop = Mid(prg, 1, brkCnt(i - 1) - 1) & "..." & _
                            Chr(10) & "[more detail available in System]"
            End If
                s = 1
            End If
        End If
        
    Loop
    End If
        
    With prgCnt
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
    With prgBrk
        '.Interior.Color = RGB(200, 200, 200)
        .Value = Left(.Value, Len(.Value) - 3)
        .IndentLevel = 5
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
        

Sheets("ref.").Cells(prgLn.Row, [Pop_PrgRng].Column).Value = prgPop


NEXT_Prg_cel:
    Set brkCnt = New Collection
    Set brkCnt = Nothing
    'MsgBox "Completed " & cel.Address(False, False) & Chr(10) & "reset brkCnt Collection.Count to: " & brkCnt.Count
Next cel
    [V22] = lnLm - 1

aSht.Activate

End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
You must log in or register to reply here.

Similar threads

L
  • Question Question
Clean Text - Remove Repeat Line Breaks
Replies
4
Views
654
lneidorf
L
Emka
  • Question Question
Web Scrap on Chrome via VBA
Replies
0
Views
103
Emka
Emka
O
  • Question Question
Frustrating intermittent VBA error dialog telling me that "User-define Type Not Defined"
Replies
1
Views
241
Micron
M
N
  • Question Question
Slow vba with opening 60 files
Replies
7
Views
269
NickvdB
N
O
  • Question Question
Cannot trap error when using Excel's built-in stock price functionality in a macro. It used to work well!
Replies
1
Views
237
OaklandJim
O

Forum statistics

Threads
1,223,893
Messages
6,175,244
Members
452,622
Latest member
Laura_PinksBTHFT

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