'### Constantes de nom de feuille (à adapter) ###
Const MAVTRE As String = "MavtRe"
Const PAVTRE As String = "PavtRe"
Const DESIGN As String = "design"
'################################################
Const MODEL As String = "___template" 'modèle de feuille (cachée)
Const MODEL2 As String = "___template2" 'modèle de feuille (cachée)
Const MODEL3 As String = "___template3" 'modèle de feuille (cachée)
Sub FeuilleGroupe()
Dim Sactive As Worksheet
Dim S As Worksheet
Dim R As Range
Dim var1
Dim var2
Dim lastCol&
Dim g&
Dim i&
Dim j&
Dim cpt&
Dim A$
Dim T()
Set Sactive = ActiveSheet
'################## MAVTRE ##################
Application.ScreenUpdating = False
On Error GoTo Erreur
Set S = Sheets(MODEL)
Set S = Sheets(MAVTRE)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[e65536].End(xlUp).Row, S.[iv4].End(xlToLeft).Column))
If R.Rows.Count < 5 Then Exit Sub
var1 = R
Set S = Sheets(DESIGN)
Set R = S.Range(S.Cells(7, 1), S.Cells(S.[a65536].End(xlUp).Row, S.UsedRange.Columns.Count))
If R.Rows.Count < 2 Then Exit Sub
var2 = R
On Error Resume Next
For i& = 2 To UBound(var2, 1)
Set S = Nothing
Set S = Sheets(var2(i&, 2))
If Not S Is Nothing Then
A$ = A$ & Space(50) & var2(i&, 2) & vbCrLf
End If
Next i&
If A$ <> "" Then
A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
MsgBox A$
Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
Sheets(MODEL).Copy After:=Sheets(Sheets.Count)
Set S = Sheets(Sheets.Count)
S.Visible = xlSheetVisible
S.Name = var2(g&, 2)
S.[e1] = "GROUPE " & var2(g&, 1)
lastCol& = S.[iv4].End(xlToLeft).Column
cpt& = 1
ReDim T(1 To 1, 1 To UBound(var1, 2))
For j& = 9 To UBound(var2, 2)
T(1, cpt&) = var2(g&, j&)
cpt& = cpt& + 2
Next j&
S.Range(S.Cells(3, 5), S.Cells(3, lastCol&)) = T
For j& = 1 To UBound(T, 2) Step 2
For i& = 5 To UBound(var1, 2) Step 2
If var1(3, i&) = T(1, j&) Then
S.Range(S.Cells(5, j& + 4), S.Cells(5, j& + 4)) = var1(UBound(var1, 1), i&)
S.Range(S.Cells(5, j& + 5), S.Cells(5, j& + 5)) = var1(UBound(var1, 1), i& + 1)
End If
Next i&
Next j&
For j& = 1 To 4
S.Range(S.Cells(5, j&), S.Cells(5, j&)) = var1(UBound(var1, 1), j&)
Next j&
With S.Range("e1")
If .MergeCells Then .MergeArea.UnMerge
End With
cpt& = S.[iv3].End(xlToLeft).Column + 1
For j& = lastCol& To cpt& + 1 Step -1
S.Columns(j&).Delete
Next j&
Set R = S.Range(S.Cells(1, 5), S.Cells(2, cpt&))
R.MergeCells = True
For j& = 7 To 10
With R.Borders(j&)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j&
Next g&
'################## PAVTRE ##################
Set S = Sheets(MODEL2)
Set S = Sheets(PAVTRE)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[e65536].End(xlUp).Row, S.[iv4].End(xlToLeft).Column))
If R.Rows.Count < 5 Then Exit Sub
var1 = R
On Error Resume Next
For i& = 2 To UBound(var2, 1)
Set S = Nothing
Set S = Sheets(var2(i&, 3))
If Not S Is Nothing Then
A$ = A$ & Space(50) & var2(i&, 3) & vbCrLf
End If
Next i&
If A$ <> "" Then
A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
MsgBox A$
Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
Sheets(MODEL2).Copy After:=Sheets(Sheets.Count)
Set S = Sheets(Sheets.Count)
S.Visible = xlSheetVisible
S.Name = var2(g&, 3)
S.[e1] = "GROUPE " & var2(g&, 1)
lastCol& = S.[iv4].End(xlToLeft).Column
cpt& = 1
ReDim T(1 To 1, 1 To UBound(var1, 2))
For j& = 9 To UBound(var2, 2)
T(1, cpt&) = var2(g&, j&)
cpt& = cpt& + 1
Next j&
S.Range(S.Cells(3, 5), S.Cells(3, lastCol&)) = T
For j& = 1 To UBound(T, 2)
For i& = 5 To UBound(var1, 2)
If var1(3, i&) = T(1, j&) Then
S.Range(S.Cells(5, j& + 4), S.Cells(5, j& + 4)) = var1(UBound(var1, 1), i&)
End If
Next i&
Next j&
For j& = 1 To 4
S.Range(S.Cells(5, j&), S.Cells(5, j&)) = var1(UBound(var1, 1), j&)
Next j&
With S.Range("e1")
If .MergeCells Then .MergeArea.UnMerge
End With
cpt& = S.[iv3].End(xlToLeft).Column
For j& = lastCol& To cpt& + 1 Step -1
S.Columns(j&).Delete
Next j&
Set R = S.Range(S.Cells(1, 5), S.Cells(2, cpt&))
R.MergeCells = True
For j& = 7 To 10
With R.Borders(j&)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j&
Next g&
'################## Observations ##################
Set S = Sheets(MODEL3)
On Error Resume Next
For i& = 2 To UBound(var2, 1)
Set S = Nothing
Set S = Sheets(var2(i&, 4))
If Not S Is Nothing Then
A$ = A$ & Space(50) & var2(i&, 4) & vbCrLf
End If
Next i&
If A$ <> "" Then
A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
MsgBox A$
Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
Sheets(MODEL3).Copy After:=Sheets(Sheets.Count)
Set S = Sheets(Sheets.Count)
S.Visible = xlSheetVisible
S.Name = var2(g&, 4)
S.[f1] = "GROUPE " & var2(g&, 1)
For j& = 9 To UBound(var2, 2)
S.Range(S.Cells(4, j& - 3), S.Cells(4, j& - 3)) = var2(g&, j&)
Next j&
With S.Range("f1")
If .MergeCells Then .MergeArea.UnMerge
End With
With S.Range("f3")
If .MergeCells Then .MergeArea.UnMerge
End With
cpt& = S.[iv4].End(xlToLeft).Column
For j& = lastCol& + 1 To cpt& + 1 Step -1
S.Columns(j&).Delete
Next j&
Set R = S.Range(S.Cells(1, 6), S.Cells(2, cpt&))
R.MergeCells = True
For j& = 7 To 10
With R.Borders(j&)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j&
Set R = S.Range(S.Cells(3, 6), S.Cells(3, cpt&))
R.MergeCells = True
For j& = 7 To 10
With R.Borders(j&)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next j&
Next g&
Sactive.Activate
Application.ScreenUpdating = True
Exit Sub
Erreur:
Application.ScreenUpdating = True
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub