Re : Split d'un classeur en plusieurs fichiers (sur critères)
Bonjour, en attendant j'ai testé un code qui se rapproche de mon besoin (voir ci-dessous) il fait un tri sur un critère (la région) et copie colle dans de nouveaux onglets le résultats des tri (1 onglet par région)...
Dans le fichier où j'ai trouvé ce code, ca fonctionne mais pas dans le mien (erreur sur la ligne Set rng = [base])
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Test")
Set rng = [base]
'extract a list of Région
ws1.Columns("A:A").Copy _
Destination:=Range("Z1")
ws1.Columns("Z").AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=Range("Z"), Unique:=True
r = Cells(Rows.Count, "AA").End(xlUp).Row
'set up Criteria Area
Range("Z1").Value = Range("A1").Value
For Each c In Range("AA2:A" & r)
'add the rep name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Test").Range("A1:AZ2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Test").Range("AZ1:AZ2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("AZ:BA").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function