Sub Eclate()
Dim DepT As Object
Dim Cel As Range
Dim Sh As Worksheet
Dim LePath As String, Nom As String
Dim DerLig As Long
Dim Interdits
Dim ThisW As Workbook
Dim Temp, NomsFeuilles, NF
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set ThisW = ThisWorkbook
LePath = ActiveWorkbook.Path & "\"
Set DepT = CreateObject("Scripting.Dictionary")
For Each Sh In ThisW.Sheets
With Sh
DerLig = .[A65000].End(xlUp).Row
For Each Cel In .Range("G2:G" & DerLig)
DepT.Item(Cel.Value) = Cel.Value
Next Cel
End With
Next Sh
Temp = Application.Transpose(DepT.Items)
Interdits = Array("[", "]", "/", "\", ":", "*", "?", "'")
NomsFeuilles = Array("RELEASED", "DRAFT", "CLOSED")
For i = LBound(Temp) To UBound(Temp)
Workbooks.Add
For Each NF In NomsFeuilles
Sheets.Add.Name = NF
Next NF
Sheets("Sheet1").Delete
Nom = Temp(i, 1)
For j = 0 To UBound(Interdits) - 1
Nom = Application.Substitute(Nom, Interdits(j), "_")
Next j
ActiveWorkbook.SaveAs LePath & Nom & ".xls"
Next i
For Each Sh In ThisW.Sheets
With Sh
DerLig = .[A65000].End(xlUp).Row
.Range("A1:BA" & DerLig).Name = "base"
.[BH1] = .[G1]
.Range("G1:G" & DerLig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
"BH1"), Unique:=True
For Each Cel In .Range("BH2:BH" & .[BH65000].End(xlUp).Row)
.[BH2] = Cel.Value
Nom = Cel.Value
For j = 0 To UBound(Interdits) - 1
Nom = Application.Substitute(Nom, Interdits(j), "_")
Next j
Set Fdest = Workbooks(Nom & ".xls").Sheets(.Name)
.Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("BH1:BH2"), _
CopyToRange:=Fdest.Range("A1"), Unique:=False
Next Cel
.Columns(60).Clear
End With
Next Sh
For i = LBound(Temp) To UBound(Temp)
Nom = Temp(i, 1)
For j = 0 To UBound(Interdits) - 1
Nom = Application.Substitute(Nom, Interdits(j), "_")
Next j
Workbooks(Nom & ".xls").Close True
Next i
Application.DisplayAlerts = True
End Sub