Bonjour,
J' ai de nouveau besoin d' aide
J' ai une erreur dans une macro permettant de diviser une feuille en plusieurs classeur suivant un filtre
J' ai une erreur mais je ne trouve pas laquelle : l' indice n' appartient pas a la sélection
Si ce n'est pas trop abusé j' aimerais aussi faire en sorte qu'on ait pas à copier le données dans l' onglet Données mais qu'il ouvre un autre fichier et copie la feuille de donnée du fichier d' origine
la macro :
Merci d' avance
J' ai de nouveau besoin d' aide
J' ai une erreur dans une macro permettant de diviser une feuille en plusieurs classeur suivant un filtre
J' ai une erreur mais je ne trouve pas laquelle : l' indice n' appartient pas a la sélection
Si ce n'est pas trop abusé j' aimerais aussi faire en sorte qu'on ait pas à copier le données dans l' onglet Données mais qu'il ouvre un autre fichier et copie la feuille de donnée du fichier d' origine
la macro :
Code:
'Divise feuille en plusieurs classeur suivant le filtre
Sub Decouper()
Dim Rg As Range
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String
Dim nom As String
Worksheets("Donnees").Select
Set Sh = ActiveSheet
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With
Do
With Rg
Workbooks("110").Activate
Worksheets("Donnees").Select
'Trier par ordre croissant
.Sort Key1:=Rg(1, 2), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=2, Criteria1:=Rg(1, 2)
Workbooks("110").Activate
Worksheets("Donnees").Select
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
Cells.Select
Selection.Copy
Set Wk = Workbooks.Add(-4167)
ActiveSheet.Paste
'Definition du nom des fichiers créés
nom = " - Code.xls"
'Ajoute le code agence en début du nom du fichier
A = Rg(1, 2).Value
ActiveWorkbook.SaveAs Filename:=A & nom
ActiveWorkbook.Close
Application.DisplayAlerts = False
Rg1.Offset(1).Delete
Workbooks("110").Activate
Worksheets("Donnees").Select
End With
Loop Until Rg(1, 2) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Set Wk = Nothing: Set Sh = Nothing
End Sub
Merci d' avance
Pièces jointes
Dernière édition: