Option Explicit
Sub Copier()
Dim LigneFeuille As Long
Dim LigneCourrier As Long
Dim ActiveCellAtStart As Range
Dim TabFeuilles() As String
Dim TabColonnesDate() As String
Dim i As Integer
Dim ErrNumber As Variant
'Noms des feuilles et noms des colonnes date
Const FeuilleCourrier = "Courrier"
Const Feuilles = "FAD,ADN,PH,BASIC,KAM,suivi2,relance,motif"
Const ColonnesDate = "O,O,O,O,S,S,S,S"
Const ColonnesACopier = "A:Z" 'Si multi-area exemple "A:D,F:S,X:X,Z:Z"
'Initialisation
TabFeuilles = Split("," & Feuilles, ",") '"," en début pour couvrir l'indice 0 non utilisé
TabColonnesDate = Split("," & ColonnesDate, ",") '"," en début pour couvrir l'indice 0 non utilisé
LigneCourrier = 2
Application.ScreenUpdating = False
Set ActiveCellAtStart = ActiveCell
'Contrôles
If UBound(TabFeuilles) <> UBound(TabColonnesDate) Then
MsgBox "Nombre d'éléments différent dans la constante ""Feuilles"" et la constante ""ColonnesDate"" !"
Exit Sub
End If
For i = 1 To UBound(TabFeuilles)
If Len(TabFeuilles(i)) = 0 Then
MsgBox "Elément n° " & i & " vide dans la constante ""Feuilles"" !"
Exit Sub
End If
If Len(TabColonnesDate(i)) = 0 Then
MsgBox "Elément n° " & i & " vide dans la constante ""ColonnesDate"" !"
Exit Sub
End If
On Error Resume Next
With ThisWorkbook.Worksheets(TabFeuilles(i))
ErrNumber = Err.Number
On Error GoTo 0
End With
'Feuille inexistante
If ErrNumber Then
MsgBox "La feuille """ & TabFeuilles(i) & """ dans la constante ""Feuilles"" n'existe pas !"
Exit Sub
End If
Next i
'Effacement des données de la feuille Courrier en préservant la ligne titre
With ThisWorkbook.Worksheets(FeuilleCourrier)
If .UsedRange.Rows.Count > 1 Then
.UsedRange.Offset(1, 0).Resize(.UsedRange.Rows.Count - 1).ClearContents
.UsedRange.Offset(1, 0).Resize(.UsedRange.Rows.Count - 1).ClearFormats
End If
End With
'Pour chacune des feuilles
For i = 1 To UBound(TabFeuilles)
With ThisWorkbook.Worksheets(TabFeuilles(i))
LigneFeuille = 2
'Pour chaque ligne de la feuille après la ligne titre
Do While Not IsEmpty(.Cells(LigneFeuille, 1))
'Si la colonne date contient une valeur
If Not IsEmpty(.Range(TabColonnesDate(i) & LigneFeuille)) Then
Intersect(.Rows(LigneFeuille), .Range(ColonnesACopier)).Copy
.Parent.Worksheets(FeuilleCourrier).Rows(LigneCourrier).PasteSpecial xlPasteAll
LigneCourrier = LigneCourrier + 1
End If
LigneFeuille = LigneFeuille + 1
Loop
End With
Next i
Application.CutCopyMode = False
ActiveCellAtStart.Select
Application.ScreenUpdating = True
MsgBox LigneCourrier - 1 & " ligne(s) copiée(s)"
End Sub
