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