N° classeur

[miliev83]

Bonjour à tous,


Voici le code :

Sub CreeClasseurs()
Dim Chemin$
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  On Error Resume Next
  [A1:z10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[ab1], Unique:=True
  For Each C In Range("ab2", Range("ab65000").End(xlUp))
     Range("ab2") = C
     Sheets("Modèle").Select
     [A2:z100].Clear
     Sheets("Test").[A1:z10000].AdvancedFilter Action:=xlFilterCopy, _
         CriteriaRange:=Sheets("Test").[ab1:ab2], CopyToRange:=Sheets("Modèle").[A1:z1], Unique:=False
       ActiveSheet.Copy
       ActiveSheet.Name = C
       Chemin = "C:\Users\Jack\Desktop\Test\Liste\Nom\"
ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8
       ActiveWorkbook.Close
       Sheets("Test").Select
    Next C
End Sub

Merci à vous

 

[Lone-wolf]

Re : Si classeur créé existe alors copier/coller à la suite ou incrémenter le nom

Bonjour miliev

À adpter à ton fichier

EDIT: ne pas prendre en considération la macro, elle n'est pas correcte

Sub Copier()
Dim Wb, AWb As Workbook, plage As Range
Application.ScreenUpdating = False
   
'Modifier le chemin C:\Users\miliev\Desktop\ ainsi que le nom des classeurs et des feuilles
   
'Ouvre le Classeur2 ou Classeur de destination
Set AWb = ThisWorkbook 'C'est le Classeur de saisie
Set Wb = Workbooks.Open("C:\Users\miliev\Desktop\Classeur1.xls")  'C'est le Classeur de destination
'Transfert les données saisies du Classeur Source dans le Classeur2
AWb.Sheets("Data").Range("a2:i" & Range("i65536").End(xlUp).Row).Copy _
Wb.Sheets("Feuil1").Range("a65536").End(xlUp)(2)
Application.DisplayAlerts = False
AWb.Save
Wb.Save

'Ouvre la boîte de dialogue "Enregistrer sous"
Application.Dialogs(xlDialogSaveAs).Show
Wb.Close True
Application.ScreenUpdating = True
End Sub

 

[Lone-wolf]

Re : Si classeur créé existe alors copier/coller à la suite ou incrémenter le nom

Re

Voici un exemple que je viens de tester. À adapter

Sub Copier()
Dim Wb As Workbook, plage As Range
Application.ScreenUpdating = False
Sheets("Data").Activate
With ActiveSheet
.Range("a1:i37").AutoFilter Field:=1, Criteria1:=ActiveCell, Operator:=xlAnd
Set Wb = Workbooks.Open("C:\Users\miliev\Desktop\Classeur1.xls")  'C'est le Classeur de destination
.Range("a2:i37").SpecialCells(xlCellTypeVisible).Copy Wb.Sheets("Feuil1").Range("a65536").End(xlUp)(2)
End With
Application.DisplayAlerts = False
Wb.Save
Wb.Close True
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Range("a1:i37").AutoFilter
End Sub

 

[miliev83]

Salut lone-wolf, merci de répondre si vite,

Sauf erreur, il me semble que ton code ne correspond pas à ce que j'imagine car le nom du classeur de destination ne peut pas être connu à l'avance,

Ce que je cherche à faire à partir de mon code c'est :

Pour la 1ère macro :
Avant

ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8

tester si le classeur existe, si réponse non alors

ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8

si oui venir copier les lignes du nom concerné, ouvrir le classeur correspondant coller les lignes à la suite

Pour la 2ème macro : Si

ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8

existe pas alors

ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8

s'il existe alors incrémenter C et enregistrer

 

[Lone-wolf]

Re : Si classeur créé existe alors copier/coller à la suite ou incrémenter le nom

Re,

D'accord. Mais j'ai bien dit qu'il fallait l'adapter; et avec la macro que j'ai mis dans ton autre post, tu devrais t'en sortir.

Edit: je remet la macro

Sub Test()
Dim rep, chemin, nom As String, i As Byte, Obj As Shape

chemin = "C:\Users\Jack\Desktop\test\test2\ABC\"
nom = "SAUVEGARDE" & ".xls" 'NOM DU CLASSEUR À CHANGER
rep = Dir(chemin & nom)

If rep <> "" Then  'SI CLASSEUR EXISTE
    Do  'AJOUTE 1 EX. SAUVEGARDE1
        rep = Dir(chemin & "SAUVEGARDE" & i + 1 & ".xls")
        i = i + 1
    Loop While rep <> ""
      'SI SAUVEGARDE1 EXISTE ALORS NOM = SAUVEGARDE2 ETC. ETC.
    ThisWorkbook.SaveAs Filename:=chemin & "SAUVEGARDE" & i & ".xls"
        Application.ScreenUpdating = False
    On Error Resume Next
    With ActiveWorkbook
    For Each Obj In .ActiveSheet.Shapes
        If Obj.Type = 8 Then Obj.Delete
    Next Obj
    Workbooks.Open chemin & nom
    Application.DisplayAlerts = False
    .Close True
    End With
Else
     'SINON SAUVEGARDE NE CHANGE PAS DE NOM
    ThisWorkbook.SaveAs Filename:=chemin & nom
End If
End Sub

 

[miliev83]

Re : Si classeur créé existe alors copier/coller à la suite ou incrémenter le nom

Merci j'essai de l'adapter

 

[Lone-wolf]

Re : Si classeur créé existe alors copier/coller à la suite ou incrémenter le nom

Bonjour miliev

ActiveWorkbook.SaveAs Filename:=Chemin & C & ".xls", FileFormat:=xlExcel8
Tu as bien un classeur de départ non? Et bien nom correspond à celui-ci.