Question

我有一个不同长度的字符串。我想把它们分成单个单元格，长度为3个字符。

ABCCBA的单元格应该在2个不同的单元格中结束ABC CBA。

ABCDABCDAB的单元格应该在4个不同的单元格中结束ABC DAB CDA B。

除此之外，一些字符是 italic ，我想在单个单元格中保留字符格式。

有没有方便的方法呢？

在VBA或公式中使用Mid()函数有效，但它不保留字符格式。

我尝试了以下操作，但代码出错了。

' Finding number of cells
Segments = WorksheetFunction.RoundUp(Len(Range("A1").Value) / 3, 0)

' Split base on character length
For n = 1 to Segments
    Cells(2, n) = Range("A1").Characters(1 + (n - 1) * 3, 3)
Next n

Answer 1

我最终做了这样的事情：

' Finding number of cells
Segments = WorksheetFunction.RoundUp(Len(Range("A1").Value) / 3, 0)
LenCel = Len(Range("A1").Value)

' Split base on character length
For n = 1 To Segments
    Range("A1").Copy
    Cells(2, n).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    Cells(2, n).Characters(1, (n - 1) * 3).Delete
    Cells(2, n).Characters(3 + 1, LenCel).Delete
Next n

我使用.PasteSpecial来处理字符格式，然后使用.Delete字符。不优雅，但是做到了。

Answer 2

这对你有用吗。

 Public Sub FormatGroupings()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim inputString As String
    Dim Segments As Long
    Dim formatCollection As New Collection
    Dim charNum As Long
    Dim Group As Long

    Set wb = ThisWorkbook
    Set ws = wb.WorkSheets("Sheet1")
    inputString = ws.Range("A1")

    Segments = WorksheetFunction.RoundUp(Len(inputString) / 3, 0)

    With ws

        For charNum = 1 To Len(inputString)

            If .Range("A1").Characters(Start:=charNum, Length:=1).Font.FontStyle = "Italic" Then
                formatCollection.Add "Italic"
            Else
                formatCollection.Add "Regular"
            End If
        Next charNum

        Dim counter As Long
        counter = 1

        For Group = 1 To Segments

            .Cells(2, Group) = Mid$(inputString, 1 + (Group - 1) * 3, 3)

            For charNum = 1 To Len(.Cells(2, Group))

                .Cells(2, Group).Characters(Start:=charNum, Length:=1).Font.FontStyle = formatCollection(counter)
                counter = counter + 1
            Next charNum

        Next Group

    End With

End Sub

或使用可能更快的数组：

 Public Sub FormatGroupings2()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim inputString As String
    Dim Segments As Long
    Dim formatArr()
    Dim charNum As Long
    Dim Group As Long

    Set wb = ThisWorkbook
    Set ws = wb.WorkSheets("Sheet1")
    inputString = ws.Range("A1")

    ReDim formatArr(Len(inputString))

    Segments = WorksheetFunction.RoundUp(Len(inputString) / 3, 0)

    With ws

        For charNum = 1 To Len(inputString)

            If .Range("A1").Characters(Start:=charNum, Length:=1).Font.FontStyle = "Italic" Then
                formatArr(charNum - 1) = "Italic"
            Else
                 formatArr(charNum - 1) = "Regular"
            End If
        Next

        Dim counter As Long
        counter = 0

        For Group = 1 To Segments

            .Cells(2, Group) = Mid$(inputString, 1 + (Group - 1) * 3, 3)

            For charNum = 1 To Len(.Cells(2, Group))

                .Cells(2, Group).Characters(Start:=charNum, Length:=1).Font.FontStyle = formatArr(counter)
                counter = counter + 1
            Next charNum

        Next Group

    End With

End Sub

VBA - 在保留字符格式的同时将单元格字符串分解为单个单元格

2 个答案: