XL 2019 VBA Copier feuilles et les enregistrer dans un fichier

[Agnesss]

Bonjour,

Je sollicite votre aide pour m'aider à coder une macro
J'ai ce fichier (le véritable fichier contient beaucoup de feuilles)
je dois copier chaque deux feuilles d'articles ex. bague et bracelet
dans un fichier et l'enregistrer dans mon bureau et ainsi de suite.
Merci de votre précieuse aide.

 

[Phil69970]

Bonjour @Agness et bienvenu sur XLD

Le fichier fourni est plus près de la bonne blague que d'un fichier exploitable

@Phil69970

 

[Agnesss]

[

Sorry, en fait je ne veux pas mettre les informations confidentieles, alors j'ai créé un fake fichier. ce qui m importe en fait est copier deux feuilles et coller dans un nouveau fichier qui sera enregistré en le renommant.

QUOTE="Phil69970, post: 20531408, member: 247145"]
Bonjour @Agness et bienvenu sur XLD

Le fichier fourni est plus près de la bonne blague que d'un fichier exploitable

@Phil69970
[/QUOTE]

Bonjour @Agness et bienvenu sur XLD

Le fichier fourni est plus près de la bonne blague que d'un fichier exploitable

@Phil69970

 

[kiki29]

Salut, quelle désinvolture ! de la même façon, à adapter à ton contexte

Option Explicit

Sub Tst()
Dim Ws As Worksheet, Cpt As Long
Dim Ar() As String
    Cpt = 0
    For Each Ws In ThisWorkbook.Worksheets
        If Left$(Ws.Name, 2) = "RF" Or Left$(Ws.Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Ws.Name
            Cpt = Cpt + 1
        End If
    Next Ws
    If Cpt = 0 Then Exit Sub
  
    Application.ScreenUpdating = False
    Sheets(Ar).Copy
    Application.DisplayAlerts = False
    ActiveWindow.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & "Test.xlsx"

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

 

[Agnesss]

Salut, quelle désinvolture ! de la même façon, à adapter à ton contexte

Option Explicit

Sub Tst()
Dim Ws As Worksheet, Cpt As Long
Dim Ar() As String
    Cpt = 0
    For Each Ws In ThisWorkbook.Worksheets
        If Left$(Ws.Name, 2) = "RF" Or Left$(Ws.Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Ws.Name
            Cpt = Cpt + 1
        End If
    Next Ws
    If Cpt = 0 Then Exit Sub
 
    Application.ScreenUpdating = False
    Sheets(Ar).Copy
    Application.DisplayAlerts = False
    ActiveWindow.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & "Test.xlsx"

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Bonjour et merci beaucoup pour votre retour Rapide
Vous êtes trop advanced pour moi. Je pense que j'aurais dû préciser que les noms de feuilles seront toujours les mêmes dans mon fichier donc j peux les indiquer dans le code,
a part les feuilles achats et ventes, toutes les autres sheets doivent être enregistées deux par deux dans un fichier renommé.
j'espère que c'est plus clair et encore une fois thanks

 

[kiki29]

Re, à toi d'œuvrer .....
Il faut créer un dossier ici baptisé "Copies", à la racine de l'appli :

ActiveWindow.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & "Copies" & "\" & "Test_2(" & j & ").xlsx"