Option Explicit
Dim Derlig As Long
Dim DerCol As Byte
Dim cell As Range
Sub LANCEMACRO()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Call Etape1
Call Etape2
Call Etape3
Call Etape4
[E16].Select
ActiveWorkbook.Names("Extract").Delete
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Etape1()
'Création_Calendrier
Dim Début, Fin As Date
Dim i As Date
Dim cell As Range, li&, col&
Début = Sheets("Feuil1").Range("E2").Value
Fin = Sheets("Feuil1").Range("E3").Value
Set cell = Sheets("Feuil1").Range("F16")
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
li = cell.Row
col = cell.Column
For i = Début To Fin
Cells(li, col).Select
With Selection
.Value = i
' .NumberFormatLocal = "jj mmmm aaaa"
.NumberFormatLocal = "jj.mm.aaaa"
.HorizontalAlignment = xlLeft
'.InsertIndent 1
' .Borders.Weight = xlThin
.Font.Bold = True
End With
col = col + 1
Next i
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Etape2()
'Copier les valeurs uniques sans doublons du tableau1[Référence]
With ActiveSheet
.Range("Tableau1[Référence]").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("E16"), Unique:=True
[E16].ClearContents 'Efface
End With
End Sub
Sub Etape3()
Dim Zone1 As Range
Dim cell As Range
Dim Derlig As Long
Dim NbLig As Long
Dim DerCol As Byte
Dim DLV As Long
Dim i As Long
'Dernière colonne
DerCol = Range("F9").End(xlToRight).Column
'MsgBox DerCol
'Dernière ligne
Derlig = Range("E17").End(xlDown).Row
'MsgBox Derlig
DLV = Range("Tableau1[Référence]").Cells.Find("*", , , , , xlPrevious).Row
'MsgBox DLV
Set Zone1 = Range("F17", Cells(Derlig, DerCol))
ActiveWorkbook.Names.Add Name:="Zone1", RefersTo:=Zone1
'MsgBox Zone1.Address
For Each cell In Zone1
For i = 2 To DLV
If Cells(cell.Row, 5).Value = Cells(i, 1) Then
If CDate(Cells(16, cell.Column).Value) = CDate(Cells(i, 3).Value) Then
cell.Value = Cells(i, 2).Value
End If
End If
Next i
Next cell
End Sub
Sub efface()
DerCol = Range("F9").End(xlToRight).Column
Derlig = Range("E17").End(xlDown).Row
With Range("E16", Cells(Derlig, DerCol))
.ClearContents 'Efface
.Interior.Pattern = xlNone
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With
End Sub
Sub Etape4()
Dim Zone2 As Range
DerCol = Range("F9").End(xlToRight).Column
Derlig = Range("E17").End(xlDown).Row
Set Zone2 = Range("G17", Cells(Derlig, DerCol))
For Each cell In Zone2
If cell.Value = "" Then
cell.Value = ""
cell.FormulaR1C1 = "=RC[-1]"
cell.Value = cell.Value
End If
If cell.Value = 0 Then
cell.Value = ""
End If
Next cell
End Sub