VBA - Rupture d'une chaîne de cellules dans des cellules individuelles tout en préservant le format de caractères

Question

J'ai une cellule avec une chaîne de longueurs différentes. Je veux les diviser en cellules individuelles avec une longueur de, disons, 3 caractères.

Une cellule avec ABCCBA doit se terminer par ABCCBA dans 2 cellules différentes.

Alors qu'une cellule avec ABCDABCDAB devrait finir par ABCDABCDAB dans 4 cellules différentes.

En plus de cela, certains des caractères sont italique, et je veux préserver le format de caractères dans les cellules individuelles.

Y at-il un moyen pratique de le faire?

---

En utilisant la fonction Mid() dans les deux œuvres VBA ou formules, mais il n'a pas conserver le format de caractères.

J'ai essayé ce qui suit, mais le code donne une erreur.

' 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

je fini par faire quelque chose comme ceci:

' 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 

je .PasteSpecial pour le format principal de caractères puis .Delete les personnages. Pas élégant, mais fait le travail.

Answer 2

Cela fonctionne pour vous.

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 

ou à l'aide d'un tableau qui est peut-être plus rapide:

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