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

Question

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

具有ABCCBA的单元应在2个不同的单元中结束ABCCBA。

虽然与ABCDABCDAB小区应该结束了ABCDABCDA在4层不同的细胞B。

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

有没有方便的方法来做到这一点？

---

在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