Sub CollerWord()
' Après avoir copié les paragraphes depuis Word dans le Press-Papier :
' - Sélectionner la Cellule A1
' - Coller (toutes les lignes Word sont collées dans la feuille avec
' 1 ligne Excel = 1 ligne Word
' Format ligne Excel = Format Ligne Word
' - Bouton Coller le contenu du Presse-Papier
' -> La colonne A est copiée en colonne B avec pour règle :
' si la ligne courante colonne A est une ligne de Titre (voir fonction EstTitre)
' Tout le Bloc de lignes qui suit sera copié en B dans une même Cellule
' en conservant le format de chaque ligne d'origine
'
Dim i As Integer, j As Integer, k As Integer, PosDeb As Double
Dim CelluleI As Range
Dim CelluleO As Range
Dim Derligne As Double
Dim Titre As Boolean
Application.ScreenUpdating = False
Derligne = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' colonne A
Range("B:B").ClearContents
' Etape 1 - Copie sans mise en forme
'-----------------------------------
k = 0
For i = 1 To Derligne
Set CelluleI = Cells(i, 1)
Titre = EstTitre(CelluleI)
If Titre Then
k = k + 1
End If
Set CelluleO = Cells(k, 2)
If Titre Then
CelluleO.Value = CelluleI.Value
PosDeb = 0
Else
PosDeb = Len(CelluleO.Value) + 1 ' à cause du VbLf
CelluleO.Value = CelluleO.Value & vbLf & CelluleI.Value
End If
Next i
' Etape 2 - Mise en forme
'------------------------
k = 0
For i = 1 To Derligne
Set CelluleI = Cells(i, 1)
Titre = EstTitre(CelluleI)
If Titre Then
k = k + 1
End If
Set CelluleO = Cells(k, 2)
If Titre Then
PosDeb = 0
Else
PosDeb = PosDeb + Len(CelluleI.Offset(-1, 0).Value) + 1 ' à cause du VbLf
End If
For j = 1 To Len(CelluleI.Value)
CelluleO.Characters(PosDeb + j, 1).Font.Bold = CelluleI.Characters(j, 1).Font.Bold
CelluleO.Characters(PosDeb + j, 1).Font.Color = CelluleI.Characters(j, 1).Font.Color
CelluleO.Characters(PosDeb + j, 1).Font.FontStyle = CelluleI.Characters(j, 1).Font.FontStyle
CelluleO.Characters(PosDeb + j, 1).Font.Italic = CelluleI.Characters(j, 1).Font.Italic
CelluleO.Characters(PosDeb + j, 1).Font.Underline = CelluleI.Characters(j, 1).Font.Underline
CelluleO.Characters(PosDeb + j, 1).Font.Size = CelluleI.Characters(j, 1).Font.Size
CelluleO.Characters(PosDeb + j, 1).Font.Name = CelluleI.Characters(j, 1).Font.Name
CelluleO.Characters(PosDeb + j, 1).Font.Strikethrough = CelluleI.Characters(j, 1).Font.Strikethrough
CelluleO.Characters(PosDeb + j, 1).Font.Subscript = CelluleI.Characters(j, 1).Font.Subscript
CelluleO.Characters(PosDeb + j, 1).Font.Superscript = CelluleI.Characters(j, 1).Font.Superscript
Next j
CelluleO.Rows.AutoFit
Next i
Set CelluleI = Nothing
Set CelluleO = Nothing
Application.ScreenUpdating = True
End Sub
Function EstTitre(pRange As Range) As Boolean
' Si les 4 caractéristiques sont les mêmes que celles de la cellule modèle
Dim i As Integer
EstTitre = True
For i = 1 To Len(pRange.Value)
If pRange.Characters(i, 1).Font.Name <> Range("MODELE_TITRE").Font.Name Or _
pRange.Characters(i, 1).Font.Bold <> Range("MODELE_TITRE").Font.Bold Or _
pRange.Characters(i, 1).Font.Size <> Range("MODELE_TITRE").Font.Size Or _
pRange.Characters(i, 1).Font.Color <> Range("MODELE_TITRE").Font.Color Then
EstTitre = False
Exit For
End If
Next i
End Function
