将列中的文本剪切为 60 个字符块答案

【问题标题】：Chop text in column to 60 charactersblocks将列中的文本剪切为 60 个字符块
【发布时间】：2014-10-27 08:25:41
【问题描述】：

我有一个包含数千行和一列的工作表(A)。 A 列中的单元格可以为空或最多为1000 个字符。我需要运行一个宏，该宏将遍历 A 列，将其复制到 B 列。如果有任何单元格包含任何文本 > 60 字符，则将其切成 60 块到下一列。

我有将文本分成60 块的代码，但我不知道如何让它复制60 下的任何内容，如果为空则移动到下一行或遍历行。

Sub x()
    Dim cLength As Long, cLoop As Long
    cLength = 60

    For cLoop = 1 To (Len([A2]) \ cLength) + 1
        [A2].Offset(, cLoop).Value = Mid([A2], ((cLoop - 1) * cLength) + 1, cLength)
    Next
End Sub

【问题讨论】：

标签： excel excel-2007 vba

【解决方案1】：

最快的处理方式！（不使用循环。一次性处理整个列）

这使用内置的Data | Text To Columns。我们使用Fixed Width 来拆分数据。下面的代码将处理长度不超过1320 个字符的字符串。

Sub Sample()
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Columns(1).TextToColumns _
        Destination:=Range("A1"), _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array( _
                        Array(0, 1), Array(60, 1), Array(120, 1), Array(180, 1), _
                        Array(240, 1), Array(300, 1), Array(360, 1), Array(420, 1), _
                        Array(480, 1), Array(540, 1), Array(600, 1), Array(660, 1), _
                        Array(720, 1), Array(780, 1), Array(840, 1), Array(900, 1), _
                        Array(960, 1), Array(1020, 1), Array(1080, 1), Array(1140, 1), _
                        Array(1200, 1), Array(1260, 1), Array(1320, 1) _
                         ), _
        TrailingMinusNumbers:=True
End Sub

如果您要手动执行此操作，那么您将执行此操作。

【讨论】：

要创建锯齿状数组，您可能希望查看THIS

【解决方案2】：

试试这个。这应该可以完成您的工作：

    Sub pCopyTextToNextColumn()

        Dim wksSheet1           As Worksheet
        Dim rngColAData         As Range
        Dim rngCell             As Range
        Dim lngLastRow          As Long
        Dim cLoop As Long

        'Set the length
        cLength = 60

        'Assign worksheet
        Set wksSheet1 = Worksheets("Sheet1")
        'find last Row in column A
        lngLastRow = wksSheet1.Cells(wksSheet1.Rows.Count, 1).End(xlUp).Row

        'Set Data range
        With wksSheet1
            Set rngColAData = .Range(.Cells(1, 1), .Cells(lngLastRow, 1))
        End With

        'Loop through each cell in column A, and
        For Each rngCell In rngColAData.Cells
            'Length of the string is greater than 60 then loop through
            If Len(Trim(rngCell)) > cLength Then

                For cLoop = 1 To (Len(rngCell) \ cLength) + 1
                    rngCell.Offset(, cLoop).Value = Mid(rngCell, ((cLoop - 1) * cLength) + 1, cLength)
                Next

            Else
            'Else just paste the data in column B
                rngCell.Offset(, 1) = rngCell.Value

            End If

        Next rngCell

        'Release Memory
        Set wksSheet1 = Nothing
        Set rngColAData = Nothing
        Set rngCell = Nothing

    End Sub

【讨论】：

【解决方案3】：

修改了您的代码，使其适用于所有行：

Sub x()
    Dim cLength As Long
    Dim cLoop As Long
    Dim i As Long

    cLength = 60
    i = 1

    While i < 1001
        For cLoop = 1 To (Len(Cells(i, 1)) \ cLength) + 1
            Cells(i, cLoop + 1).Value = Mid(Cells(i, 1), ((cLoop - 1) * cLength) + 1, cLength)
        Next
        i = i + 1
    Wend
End Sub

【讨论】：