Re : Création d'un fichier par macro avec intégration d'une nouvelle macro
Bonjour,
j'ai essayer de retravailler ma macro avec ton idée (TempusFugit).
mais j'ai un gros souci : c'est qu'il ferme à chaque fois mon fichier source ce qui est assez ennuyeux car ma macro ne peut plus fonctionner et ne peut donc plus creer d'onglets autant qu'il existe de valeurs uniques dans la colonne B.
merci si vous pouvez m'éclaircir sur ce point...
Merci pour votre aide,
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("Extraction").Select
Set Sh = ActiveSheet
With Sh
Set Rg = .Range("A1:Z" & .Range("A65536").End(xlUp).Row)
End With
Do
With Rg
Workbooks("fichier extraction.xlsm").Activate
Worksheets("Extraction").Select
'Trier par ordre croissant
.Sort Key1:=Rg(2, 2), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=2, Criteria1:=Rg(2, 2)
Workbooks("fichier extraction.xlsm").Activate
Worksheets("Extraction").Select
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Worksheets.Add
ActiveSheet.PasteSpecial
ActiveSheet.Name = Worksheets("Extraction").Range("B2").Value
Worksheets("Feuil2").Delete
nom = ".xlsm"
'Ajoute le code agence en début du nom du fichier
A = Rg(2, 2).Value
ActiveWorkbook.SaveCopyAs Filename:="O:\Controlling\Clot2012\FIRE\FC\9+4\" & A & nom
ActiveWorkbook.Close
'Definition du nom des fichiers créés
Application.DisplayAlerts = False
Rg1.Offset(1).Delete
Workbooks("fichier extraction.xlsm").Activate
Worksheets("Extraction").Select
End With
Loop Until Rg(2, 2) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Set Wk = Nothing: Set Sh = Nothing
End Sub