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

不确定这是否会编译/运行但它应该给你一般的想法

在Excel VBA中创建一个wordwrap函数

2 个答案: