1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
| Sub Test()
Dim R As Range
Dim L As Long
Dim Spl2, Spl3, Spl4
Dim Nb As Integer
Set R = ActiveSheet.UsedRange
For L = R.Rows.Count To 2 Step -1
Nb = -1
Spl2 = Split(R(L, 2), Chr(10))
Spl3 = Split(R(L, 3), Chr(10))
Spl4 = Split(R(L, 4), Chr(10))
If UBound(Spl2) > Nb Then Nb = UBound(Spl2)
If UBound(Spl3) > Nb Then Nb = UBound(Spl3)
If UBound(Spl4) > Nb Then Nb = UBound(Spl4)
If Nb > 0 Then
R.Range(R(L + 1, 1), R(L + 1, 1).Offset(Nb - 1)).EntireRow.Insert
If UBound(Spl2) > -1 Then R.Range(R(L, 2), R(L, 2).Offset(UBound(Spl2))) = Application.Transpose(Spl2)
If UBound(Spl3) > -1 Then R.Range(R(L, 3), R(L, 3).Offset(UBound(Spl3))) = Application.Transpose(Spl3)
If UBound(Spl4) > -1 Then R.Range(R(L, 4), R(L, 4).Offset(UBound(Spl4))) = Application.Transpose(Spl4)
R.Range(R(L, 1), R(L, 1).Offset(Nb)) = R(L, 1)
R.Range(R(L, 5), R(L, 5).Offset(Nb)) = R(L, 5)
MiseEnPage R.Range(R(L, 1), R(L, 5).Offset(Nb))
End If
Next
End Sub
Sub MiseEnPage(R As Range)
With R.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
With R.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
With R.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
With R.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
With R.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
With R.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Color = -6710887
.TintAndShade = 0
.Weight = xlThick
End With
End Sub |
Partager