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

Question

通过大量研究，我找到了一个代码，用于将存储在单元格中的情感截断为100个字符或更少，并将多余的部分添加到第二个字符串中。 我一直在努力将其转换为功能。

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

即wordWrap的wordWrap（输入“范围或数组”，maxLength为整数）的输出将是结果数组

这是我当前的代码：

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

因此，如果以最大100个字符输入（“ B2：B6”）范围或等效数组 ：

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

不知道这是否可以编译/运行，但应该可以为您提供总体思路