在Excel VBA中创建自动换行功能

Question

Through much research I have figured out a code to truncate sentances stored in cells to 100 characters or less, and add the excess to a second string. I have been really struggling trying to turn this into a function.

I would like to have the function accept a range of (1 column by various rows) OR, if that isn't possible, an Array of the same range values. Also there should be a way to set the number of characters that each output string can hold, output as an array of strings.

ie wordWrap(Input 'range or array', maxLength as integer) output of wordWrap will be an array of the results

Here is my current code:

Sub wordWrap()
'This procedure is intended to check the character length of a string and truncate all the words over 100 characters
'To a second string.  (basically a word wrap)

Dim sumCount As Integer, newCount As Integer, i As Integer
Dim newString As String, newString2 As String
Dim words As Variant
Dim lenwords(0 To 1000) As Variant
Dim myRange As Range
sumCount = 0
newCount = 0
newString = ""
newString2 = ""
With Range("Q:Q")
    .NumberFormat = "@"
End With
Set myRange = Range("B3")
words = Split(myRange.Value, " ")
For i = 0 To UBound(words)
    lenwords(i) = Len(words(i))
    Range("Q3").Offset(i, 0) = CStr(words(i)) 'DEBUG
    Range("R3").Offset(i, 0) = lenwords(i) 'DEBUG
    If sumCount + (lenwords(i) + 1) < 100 Then
        sumCount = sumCount + (lenwords(i) + 1)
        newString = newString & " " & words(i)
    Else
        newCount = newCount + (lenwords(i) + 1)
        newString2 = newString2 & " " & words(i)
    End If
Next
'DEBUG
Range("S3") = CStr(newString)
Range("T3") = Trim(CStr(newString2))
Range("S4") = Len(newString)
Range("T4") = Len(newString2)
ActiveSheet.UsedRange.Columns.AutoFit
End Sub

So if a range of ("B2:B6") or equivalent array are entered at max 100 characters:

c = wordWrap(Range("B2:B6"),100) 

Basically what this should do is count the length of each cell(or element) and truncate any extra words that make the string over 100 characters and concatenate them to the front of the next element in the output array to the next element of the output array. If that would put that element over 100 characters, then do the same process again until all of the elements contain sentence strings less then 100 characters long. It should add an extra element at the end to fit any leftover words.

I have been tearing out my hair trying to get this to work. I could use the advice of the experts.

Any help appreciated.

Example asked for:

http://s21.postimg.org/iywbgy307/trunc_ex.jpg

The ouput should be into an array, though, and not directly back to the worksheet.

Answer 1

The function:

Function WordWrap(ByVal Rng As Range, Optional ByVal MaxLength As Long = 100) As String()

    Dim rCell As Range
    Dim arrOutput() As String
    Dim sTemp As String
    Dim OutputIndex As Long
    Dim i As Long

    ReDim arrOutput(1 To Evaluate("CEILING(SUM(LEN(" & Rng.Address(External:=True) & "))," & MaxLength & ")/" & MaxLength) * 2)
    For Each rCell In Rng.Cells
        If Len(Trim(sTemp & " " & rCell.Text)) > MaxLength Then
            OutputIndex = OutputIndex + 1
            arrOutput(OutputIndex) = Trim(Left(sTemp & " " & rCell.Text, InStrRev(Left(sTemp & " " & rCell.Text, MaxLength), " ")))
            sTemp = Trim(Mid(sTemp & " " & rCell.Text, Len(arrOutput(OutputIndex)) + 2))
            For i = 1 To Len(sTemp) Step MaxLength
                If Len(sTemp) < MaxLength Then Exit For
                OutputIndex = OutputIndex + 1
                arrOutput(OutputIndex) = Trim(Left(sTemp, InStrRev(Left(sTemp, MaxLength), " ")))
                sTemp = Trim(Mid(sTemp, Len(arrOutput(OutputIndex)) + 2))
            Next i
        Else
            OutputIndex = OutputIndex + 1
            arrOutput(OutputIndex) = Trim(sTemp & " " & rCell.Text)
            sTemp = ""
        End If
    Next rCell
    OutputIndex = OutputIndex + 1
    arrOutput(OutputIndex) = sTemp

    ReDim Preserve arrOutput(1 To OutputIndex)
    WordWrap = arrOutput

    Erase arrOutput

End Function

The call:

Sub tgr()

    Dim arrWrapped() As String

    arrWrapped = WordWrap(Range("B2:B6"), 100)
    MsgBox Join(arrWrapped, Chr(10) & Chr(10))

End Sub

Instead of a msgbox, you could output it to a sheet, or do whatever else you wanted.

Answer 2

going to say you get passed a string, and want to return an array

performance might be slow with this approach

dim words(1) as variant
dim lastSpace as Integer
dim i as Integer

words(1) = Cells(1, 1)

while(Len(words(UBound(words) - 1)) > 100) 'check if the newest array is > 100 characters
    Redim words(UBound(words) + 1)
    'find the last space
    for i = 0 to 100
        if(words(i) = " ") Then
            lastSpace = i
        EndIF
    Next
    words(UBound(words) - 1) = Mid(words(UBound(words) - 2), lastSpace) 'copy words after the last space before the 100th character
    words(UBound(words) - 2) = Left(words(UBound(words) - 2), 100 - lastSpace) 'copy the words from the beginning to the last space
Wend

Not sure if this will compile/run but it should give you the general idea