在 Excel VBA 中创建自动换行函数

Question

通过大量研究，我找到了一个代码，可以将存储在单元格中的句子截断为 100 个字符或更少，并将多余的部分添加到第二个字符串中。我一直在努力尝试把它变成一个函数。

我想让函数接受一个范围（1 列，不同的行），或者，如果不可能的话，一个相同范围值的数组。另外应该有一种方法可以设置每个输出字符串可以容纳的字符数，输出为字符串数组。

即wordWrap(Input 'range or array', maxLength as integer) wordWrap 的输出将是一个结果数组

这是我当前的代码：

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

因此，如果 ("B2:B6") 或等效数组 的范围最多输入 100 个字符：

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

基本上，这应该做的是计算每个单元格（或元素）的长度，并截断任何使字符串超过 100 个字符的额外单词，并将它们连接到输出数组中下一个元素的前面到下一个元素输出数组。如果这会使该元素超过 100 个字符，则再次执行相同的过程，直到所有元素包含少于 100 个字符长的句子字符串。它应该在末尾添加一个额外的元素以适应任何剩余的单词。

我一直在扯头发，试图让它发挥作用。我可以参考专家的建议。

任何帮助表示赞赏。

要求的示例：

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

不过，输出应该是一个数组，而不是直接返回到工作表。

Answer 1

功能：

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

电话：

Sub tgr()

    Dim arrWrapped() As String

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

End Sub

您可以将其输出到工作表中，而不是 msgbox，或者做任何您想做的事情。

Answer 2

说你得到了一个字符串，并想要返回一个数组

这种方法可能会降低性能

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

不确定这是否会编译/运行，但它应该会给你一个大致的思路