按长度拆分文本并插入包含空白单元格的行

Question

我还需要在它创建的新行中包含空白单元格。

Sub test()
Dim txt As String, temp As String, colA As String, colB As String
Dim a, b() As String, n, i As Long
Const myLen As Long = 70
a = Range("a1").CurrentRegion.Value
ReDim b(1 To Rows.Count, 1 To 3)
For i = 1 To UBound(a, 1)
    If a(i, 1) <> "" Then
        colA = a(i, 1)
        colB = a(i, 2)
        txt = Trim(a(i, 3))
        Do While Len(txt)
            If Len(txt) <= myLen Then
                temp = txt
            Else
                temp = Left$(txt, InStrRev(txt, " ", myLen))
            End If
            If temp = "" Then Exit Do
            n = n + 1
            b(n, 1) = colA: b(n, 2) = colB
            b(n, 3) = Trim(temp)
            txt = Trim(Mid$(txt, Len(temp) + 1))
        Loop
    End If
Next
Range("e1").Resize(n, 3).Value = b
End Sub

我尝试使用 not with "" 和 ReDim。

Answer 1

• 注释掉

  If a(i, 1) <> "" Then

  和

  End If

  以包含 A 列上的空白单元格。
• Const

  MAX_CNT

  表示每行数据拆分后的最大行数。
• 如果在第一次 Redim 之后使用

  Redim

  调整数组大小，则只能更改

  last

  维度。最初声明一个足够大的数组来处理数据会更容易。

Sub test()
    Dim txt As String, temp As String, colA As String, colB As String
    Dim a, b() As String, n, i As Long
    Const myLen As Long = 70
    Const MAX_CNT As Long = 10  ' modify as needed
    a = Range("a1").CurrentRegion.Value
    ReDim b(1 To Rows.Count * MAX_CNT, 1 To 3)
    For i = 1 To UBound(a, 1)
'        If a(i, 1) <> "" Then ' ** remove
            colA = a(i, 1)
            colB = a(i, 2)
            txt = Trim(a(i, 3))
            Do While Len(txt)
                If Len(txt) <= myLen Then
                    temp = txt
                Else
                    temp = Left$(txt, InStrRev(txt, " ", myLen))
                End If
                If temp = "" Then Exit Do
                n = n + 1
                b(n, 1) = colA
                b(n, 2) = colB
                b(n, 3) = Trim(temp)
                txt = Trim(Mid$(txt, Len(temp) + 1))
            Loop
'        End If ' ** remove
    Next
    Range("e1").Resize(n, 3).Value = b
End Sub