Option Explicit
Option Base 1
Sub Lettre_Mission()
Const Lgn_Déb = 4, Col_Déb = "B" 'Début des données exploitées
Dim chemin$
Dim Col_Baliseurs, Col_Infos, i As Long, lgn_Fin As Long, j As Long, k, m As Long
Dim Dic As New Scripting.Dictionary
Dim Wsh_GR As Worksheet, Wsh_PR As Worksheet, Wsh_Lettre As Worksheet, Feuilles As Sheets, Sh As Worksheet
Dim Col_Fin, Clef, Missions, Tb_Missions()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
chemin = ThisWorkbook.Path & "\Lettres de Mission " & Feuil1.[H1] & "\" 'à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
Col_Fin = Array("J", "I") 'Colonne de fin sur les feuilles
Col_Baliseurs = Array(Array(6, 7, 8, 9), Array(5, 6, 7, 8)) 'N° de colonne dans le tableau VB (commence en "B")
Col_Infos = Array(Array(1, 3, 4), Array(1, 2)) 'N° de colonne dans le tableau VB (commence en "B")
Set Wsh_GR = Feuil1: Set Wsh_PR = Feuil3: Set Wsh_Lettre = Feuil5
Set Feuilles = Sheets(Array(Wsh_GR.Name, Wsh_PR.Name))
ReDim Tb(1 To Feuilles.Count), tb_Temp(1 To Feuilles.Count)
i = 1
'Constitution de la liste des missions pour chaque baliseurs
For Each Sh In Feuilles
lgn_Fin = Sh.Range(Col_Déb & Sh.Rows.Count).End(xlUp).Row
Tb(i) = Sh.Range(Col_Déb & Lgn_Déb, Col_Fin(i) & lgn_Fin).Value
For j = 1 To UBound(Tb(i), 1)
For Each k In Col_Baliseurs(i)
If Tb(i)(j, k) <> "" Then
If Dic.Exists(Tb(i)(j, k)) Then
tb_Temp = Dic(Tb(i)(j, k)): tb_Temp(i) = IIf(tb_Temp(i) = "", j, tb_Temp(i) & "¤" & j)
Else
tb_Temp = Array("", ""): tb_Temp(i) = j
End If
Dic(Tb(i)(j, k)) = tb_Temp
End If
Next k
Next j
i = i + 1
Next Sh
'Création de la liste des missions, remplissage de la lettre, enregistrement des fichiers
For Each Clef In Dic
If Clef <> "" Then
Erase Tb_Missions
k = 0
For i = 1 To UBound(Dic(Clef))
If Dic(Clef)(i) <> "" Then
Missions = Split(Dic(Clef)(i), "¤")
For j = 0 To UBound(Missions)
k = k + 1
ReDim Preserve Tb_Missions(1 To 3, 1 To k)
m = CInt(Missions(j))
Tb_Missions(1, k) = Tb(i)(m, Col_Infos(i)(1))
Tb_Missions(2, k) = Tb(i)(m, Col_Infos(i)(2))
If UBound(Col_Infos(i)) = 3 Then Tb_Missions(3, k) = Tb(i)(m, Col_Infos(i)(3))
Next j
End If
Next i
tb_Temp = WorksheetFunction.Transpose(Tb_Missions)
Wsh_Lettre.Copy
Set Sh = ActiveSheet
Sh.[_Prénom_Nom_Lettre] = Clef
Sh.[_Prénom_Nom_Fiche] = Clef
m = UBound(Tb_Missions, 2)
If m > 1 Then
Sh.[_Lst_Missions].Offset(1).EntireRow.Resize(m - 1).Insert Shift:=xlDown
Sh.[_Lst_Missions].EntireRow.Copy Sh.[_Lst_Missions].Offset(1).EntireRow.Resize(m - 1)
End If
With Sh.[_Hauteur_Lignes].Resize(m, 3)
.Value = tb_Temp
.EntireRow.AutoFit
End With
Sh.[_Lst_Missions].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 1)
Sh.[_Début].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 2)
Sh.[_Fin].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 3)
Sh.[_Hauteur_Lignes].EntireColumn.Resize(, 3).Delete
Sh.Name = Clef
Sh.Parent.SaveAs chemin & Clef & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End If
Next Clef
'Fermeture des fichiers dans un deuxième temps
'(car j'ai des problèmes de synchronisation si je le fais dans la foulée)
For Each Clef In Dic
Workbooks(Clef & ".xlsx").Close False
Next Clef
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub