Option Explicit
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OA As Worksheet 'déclare la variable OA (Onglet A)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim LI As Integer 'déclare la variable LI (Ligne)
Dim DA As Long 'déclare la variable DA (Date Aujourd'hui)
Dim DN As Long 'déclare la variable DN (Date Navire)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeru destination CD
CA = CD.Path & "\" 'définit le chemin d'accès CA
Set OA = CD.Worksheets("A") 'définit l'onglet OA
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("B1.xlsx") 'définit le classeur source CS (génère une erreur s'il n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
Err.Clear 'supprime l'erreur
Set CS = Application.Workbooks.Open(CA & "B1.xlsm") 'définit le classeur source SC (en l'ouvrant)
End If 'fin de la condition
On Error GoTo 0 'fin de la gestion des erreurs
Set OS = CS.Worksheets("base") 'définit l'onglet source OS
TS = OS.Range("A1").CurrentRegion 'définit la tableau source TS
TD = OA.Range("A1").CurrentRegion 'définit la tableau destination TD
DA = CLng(DateSerial(Year(Date), Month(Date), Day(Date)))
For I = 2 To UBound(TD, 1) 'boucle 1 sur toutes les lignes I du tableau detination TD (en partant de la seconde)
DN = CLng(DateSerial(Year(TD(I, 3)), Month(TD(I, 3)), Day(TD(I, 3))))
If DA > DN + 7 Then 'condition 1 : si la date du jour est supérieure a la date de fin + 7 jours
K = 1: Erase TL 'initialise la variable K, vide le tableau ds lignes TL
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set OD = Worksheets(TD(I, 1)) 'définit l'onglet destination OD (génère une erreur si l'onglet n'existe pas)
If Err <> 0 Then 'condition 2: si une erreur a été générée
Err.Clear 'supprime l'erreur
Set OD = CD.Application.Worksheets.Add 'définit l'onglet OD (en ajoutant un onglet vierge)
OD.Move After:=Sheets(Sheets.Count) 'repositionne l'onglet OD en dernière position
OD.Name = TD(I, 1) 'renomme l'onglet OD
OD.Range("A1").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 1) 'récupère la première ligne du tableau source TS
With OD.Rows(1).Cells 'prend en compte la ligne 1 de l'onglet OD
.HorizontalAlignment = xlCenter 'alignement horizontal centré
.VerticalAlignment = xlCenter 'alignement vertical centré
.WrapText = True 'renvoie des mots à la ligne
End With 'fin de la prise en compte la ligne 1 de l'onglet OD
OD.Range("A2").Resize(1, UBound(TS, 2)).Value = Application.Index(TS, 2) 'récupère la seconde ligne du tableau source TS
End If 'fin de la condition 2
On Error GoTo 0 'fin de la gestion des erreurs
LI = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1 'définit la ligne LI
For J = 3 To UBound(TS, 1) 'boucle 2 : sur toutes ligne J du tableau source TS (en partant de la troisième)
If TD(I, 4) = TS(J, 1) Then 'condition 3 : si la donnée ligne I colonne 4 du tableau destination TD est égale à la donnée ligne J colonne 1 du tableau source TS
ReDim Preserve TL(1 To UBound(TS, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TS a de colonnes, K colonnes)
For L = 1 To UBound(TS, 2) 'boucle 3 : sur toutes colonnes K du tableau source TS
TL(L, K) = TS(J, L) 'récupère dans la ligne L de TL la donnée en colonne L de TS (=> trasposition)
Next L 'prochaine colonne de la boucle 3
K = K + 1 'incrémente K'ajoute une colonne au tableau des lignes
End If 'fin de la condition 3
Next J 'prochaine colonne de la boucle 2
'si K est supérieure à 1, rnvoie le tableau TL tranposé dans la cellule ligne LI colonne A redimensionnée
If K > 1 Then OD.Cells(LI, "A").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub