Sub CopyDecaler()
'
' Macro pour Copy décaler
'
Dim aAdrCell_Depart(7) As String
Dim aAdrCell_Arrive(7) As String
Dim lnDesti As Integer
' Tableau des adresses de départs
aAdrCell_Depart(1) = "B5:E5"
aAdrCell_Depart(2) = "G5:J5"
aAdrCell_Depart(3) = "L5:O5"
aAdrCell_Depart(4) = "Q5:T5"
aAdrCell_Depart(5) = "V5:Y5"
aAdrCell_Depart(6) = "AA5:AD5"
aAdrCell_Depart(7) = "AF5:AI5"
' Tableau des adresses d'arrivé
aAdrCell_Arrive(1) = "B11:E11"
aAdrCell_Arrive(2) = "G11:J11"
aAdrCell_Arrive(3) = "L11:O11"
aAdrCell_Arrive(4) = "Q11:T11"
aAdrCell_Arrive(5) = "V11:Y11"
aAdrCell_Arrive(6) = "AA11:AD11"
aAdrCell_Arrive(7) = "AF11:AI11"
' Index table de destination
lnDesti = 1
' boucle sur le table de départ
For lnA = 1 To 7
' Controle si une des cellule de la seleciton est rempli
If CtrlContenu(aAdrCell_Depart(lnA)) Then
Range(aAdrCell_Depart(lnA)).Select
Selection.Copy
CopySpecial (aAdrCell_Arrive(lnDesti))
lnDesti = lnDesti + 1
End If
Next
End Sub
'
'
'Copy spéciale sur avec parametre adresse de cellule
'
Sub CopySpecial(tcAdress As String)
Range(tcAdress).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
'
'
' Controle le contenu de chaque cellule
'
Function CtrlContenu(tcAdresse As String)
Dim lnReturn As Boolean
lnReturn = False
For Each Cell In Range(tcAdresse)
If Cell.Value <> "" Then
lnReturn = True
End If
Next
CtrlContenu = lnReturn
End Function