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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
| Option Explicit
Sub Fusionner()
Dim wbk As Workbook, wsh As Worksheet, rng As Range
Dim noL As Long, nL1 As Long, nL2 As Long, nL3 As Long, nbL As Integer
Dim valC1, valC2, valC3
Const nLP% = 39 ' nombre de lignes de données par page
' Créer une copie de la feuille dans un fichier temporaire
ThisWorkbook.Worksheets("ROUGES").Copy
Set wbk = ActiveWorkbook
Set wsh = wbk.Worksheets(1)
' Convertir le tableau en plage
wsh.ListObjects(1).Unlist
' Plage
Set rng = wsh.Range("A4").CurrentRegion
' Plage des données (Plage sauf titres)
Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
' Analyse des données ligne à ligne
valC1 = rng(1, 1).Value: nL1 = 1
valC2 = rng(1, 2).Value: nL2 = 1
valC3 = rng(1, 3).Value: nL3 = 1
For noL = 1 To rng.Rows.Count
' nombre de lignes de la page
nbL = nbL + 1
If nbL = nLP Then
' fin de page
Application.DisplayAlerts = False
With rng(nL1, 1).Resize(noL + 1 - nL1)
.MergeCells = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
End With
With rng(nL2, 2).Resize(noL + 1 - nL2)
.MergeCells = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
End With
With rng(nL3, 3).Resize(noL + 1 - nL3)
.MergeCells = True
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True
valC1 = rng(noL + 1, 1): nL1 = noL + 1
valC2 = rng(noL + 1, 2): nL2 = noL + 1
valC3 = rng(noL + 1, 3): nL3 = noL + 1
nbL = 0
End If
If rng(noL + 1, 1).Value <> valC1 Then
' fin de plage à fusionner colonne 1
Application.DisplayAlerts = False
With rng(nL1, 1).Resize(noL + 1 - nL1)
.MergeCells = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
End With
Application.DisplayAlerts = True
valC1 = rng(noL + 1, 1): nL1 = noL + 1
End If
If rng(noL + 1, 2).Value <> valC2 Or _
rng(noL + 1, 1).Value <> valC1 Then
' fin de plage à fusionner colonne 2
Application.DisplayAlerts = False
With rng(nL2, 2).Resize(noL + 1 - nL2)
.MergeCells = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
End With
Application.DisplayAlerts = True
valC2 = rng(noL + 1, 2): nL2 = noL + 1
End If
If rng(noL + 1, 3).Value <> valC3 Or _
rng(noL + 1, 2).Value <> valC2 Or _
rng(noL + 1, 1).Value <> valC1 Then
' fin de plage à fusionner colonne 2
Application.DisplayAlerts = False
With rng(nL3, 3).Resize(noL + 1 - nL3)
.MergeCells = True
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True
valC3 = rng(noL + 1, 3): nL3 = noL + 1
End If
Next noL
End Sub |
Partager