XL 2013 extraction personnalisée + copie dans nouveau classeur du même répertoire

jmten92 · 5 Novembre 2016

Bonjour, j'ai un petit problème que j'ai tenté de résoudre avec du code mais ca ne marche pas , si quelqu'un a une idée de ce qui cloche ... un grand merci par avance ...

en gros :
j'ai un fichier (en pj) qui comporte plusieurs onglets qui sont les suivants TCD RETARD RUSSIE -BDD RUSSIE-TCD RETARD SGEF - BDD SGEF..... (au total 6 comme ca).

je souhaite pouvoir copier dans un nouveau classeur du même répertoire chaque binôme (exemple TCD RETARD RUSSIE et BDD RUSSIE) .ce binôme devra être réuni dans un classeur qui s'appellera RUSSIE et ou en feuille 1 j'aurai le TCD RETARD RUSSIE et en feuille 2 j'aurai BDD RUSSIE ...

Et ca pour mes 6 binômes ... donc au total 6 classeurs générés....

une idée du code qu'il faut ? j'ai cette base la mais ca ne marche pas ....

Sub iCopy_Sheets()

Dim wb As Workbook, i As Byte, ii As Byte, c, sh, shh, iPath As String
Set wb = Workbooks.Add
iPath = ThisWorkbook.Path & "\"
With wb
For i = 1 To 1
Set sh = .Worksheets.Add: sh.Name = "BDD RUSSIE": sh.Move After:=Sheets(.Sheets.Count)
Next
For ii = 1 To 1
Set shh = .Worksheets.Add: shh.Name = "TCD RETARD RUSSIE": shh.Move After:=Sheets(.Sheets.Count)
Next
Application.DisplayAlerts = False: Application.ScreenUpdating = False
.SaveAs Filename:=iPath & "RUSSIE"
For Each c In .Sheets
ThisWorkbook.Sheets("BDD RUSSIE").Cells.Copy
If Left(c.Name, 3) = "BDD RUSSIE" Then c.Paste
ThisWorkbook.Sheets("TCD RETARD RUSSIE").Cells.Copy
If Left(c.Name, 6) = "Retard" Then c.Paste
If Left(c.Name, 3) = "BDD" Or Left(c.Name, 6) = "Retard" Then GoTo 100
c.Delete
100
Next c
.Save: .Close: End With
Application.DisplayAlerts = True: Application.ScreenUpdating = True

End Sub

Un grand merci a ceux qui prendront le temps de se pencher sur mon problème ...

Robert · 5 Novembre 2016

Bonjour Jmten, bonjour le forum,

Peut-être comme ça :

VB:

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)

Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
For I = 1 To CS.Sheets.Count 'boucle 1 : sur tous les onglets du classeur source
    Select Case Split(CS.Sheets(I).Name, " ")(1) 'agit en fonction du mot après le premier espace du nom de l'onglet
        Case "RETARD" 'cas "RETARD"
            On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
            Set CD = Workbooks(Split(CS.Sheets(I).Name, " ")(2) & ".xlsx")
            'définit le classeur de destination CD (génère une erreur si ce classeur n'est pas ouvert)
            'le nom du classeur correspond au mot après le second espace du nom de l'onglet
            If Err <> 0 Then 'condition : si une erreur a été générée
                Err.Clear 'supprime l'erreur
                Workbooks.Add 'ajoute un classeur vierge
                Set CD = ActiveWorkbook 'définit la classeur de destination CD
                CD.SaveAs (CH & Split(CS.Sheets(I).Name, " ")(2) & ".xlsx")
                'enregistreSous le classeur avec le même chemin d'accès et avec le mot après le second espace du nom de l'onglet
            End If 'fin de la condition
            On Error GoTo 0 'annule la gestion des erreurs
            CS.Sheets(I).Copy Before:=CD.Sheets(1) 'copie l'onglet I du classeur source en premier dans le classeur destination
        Case Else 'tous les autres cas
            CS.Sheets(I).Copy Before:=CD.Sheets(2) 'copie l'onglet I du classeur source en second dans le classeur destination
            Application.DisplayAlerts = False 'empêche les messages d'Excel
            For J = CD.Sheets.Count To 3 Step -1 'boucle 2 : sur les derniers onglets à partir du troisième
                CD.Sheets(J).Delete 'supprime l'onglet
            Next J 'prochain onglet de la boucle 2
            Application.DisplayAlerts = True 'permet les messages d'Excel
            CD.Close Savechanges:=True 'ferme le classeur destination en enregistrant les modifications
    End Select 'fin de l'action en fonction du mot après le premier espace du nom de l'onglet
Next I 'prochain onglet de la boucle 1
End Sub

jmten92 · 5 Novembre 2016

Bonjour un grand merci pour ce code
toutefois j'ai une erreur qui s'affiche sur la ligne suivante qui se met en jaune (erreur 9 : l'indice n'appartient pas a la selection...)

Select Case Split(CS.Sheets(I).Name, " ")(1) 'agit en fonction du mot après le premier espace du nom de l'onglet
Case "RETARD" 'cas "RETARD"
une idée de ce que cela peut être ?

Merci

Robert · 5 Novembre 2016

Re,

J'ai testé sans erreur avec les deux binômes que tu as fourni. Cette erreur signifie que le nom d'un des onglets ne possède pas d'espace (le caractère espace : " "). Puisque tu n'as que 6 binômes, pourrais-tu fournir la liste de tous les onglets du classeur ?

[Édition]

Ooops, Désolé je n'avais pas vu que tu avais mis une pièce jointe !... Je regarde à nouveau.

jmten92 · 5 Novembre 2016

merci
effectivement j'ai deux onglets dont le nom ne comporte pas d'espace : "BDD" et Périmètre".
mais ils ne rentrent pas dans le cadre de mes binômes donc on peut les exclure de la boucle mais je ne sais pas comment faire ...

Robert · 5 Novembre 2016

Re,

C'était bien cela !... En fait, l'énoncé ne correspond pas à la réalité du fichier. En regardant la pièce jointe j'ai corrigé le problème :

VB:

Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)

Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
For I = 1 To CS.Sheets.Count 'boucle 1 : sur tous les onglets du classeur source
    Select Case CS.Sheets(I).Name 'agit en fonction du nom de l'onglet
        'mettre ici la liste de tous les onglets non concernés
        Case "Retard TCD", "BDD", "Périmètre", "Data_Retards_Agrégé", "Data_Retards_Détail", "Data_Retards_SAVANCE"
        'pour les cas ci-dessus, rien ne se passe
        Case Else 'pour tous les autre cas
            Select Case Split(CS.Sheets(I).Name, " ")(1) 'agit en fonction du mot après le premier espace du nom de l'onglet
                Case "RETARD" 'cas "RETARD"
                    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                    Set CD = Workbooks(Split(CS.Sheets(I).Name, " ")(2) & ".xlsx")
                     'définit le classeur de destination CD (génère une erreur si ce classeur n'est pas ouvert)
                    'le nom du classeur correspond au mot après le second espace du nom de l'onglet
                    If Err <> 0 Then 'condition : si une erreur a été générée
                        Err.Clear 'supprime l'erreur
                        Workbooks.Add 'ajoute un classeur vierge
                        Set CD = ActiveWorkbook 'définit la classeur de destination CD
                        CD.SaveAs (CH & Split(CS.Sheets(I).Name, " ")(2) & ".xlsx")
                         'enregistreSous le classeur avec le même chemin d'accès et avec le mot après le second espace du nom de l'onglet
                    End If 'fin de la condition
                    On Error GoTo 0 'annule la gestion des erreurs
                    CS.Sheets(I).Copy Before:=CD.Sheets(1) 'copie l'onglet I du classeur source en premier dans le classeur destination
                Case Else 'tous les autres cas
                    CS.Sheets(I).Copy Before:=CD.Sheets(2) 'copie l'onglet I du classeur source en second dans le classeur destination
                    Application.DisplayAlerts = False 'empêche les messages d'Excel
                    For J = CD.Sheets.Count To 3 Step -1 'boucle 2 : sur les derniers onglets à partir du troisième
                        CD.Sheets(J).Delete 'supprime l'onglet
                    Next J 'prochain onglet de la boucle 2
                    Application.DisplayAlerts = True 'permet les messages d'Excel
                    CD.Close Savechanges:=True 'ferme le classeur destination en enregistrant les modifications
            End Select 'fin de l'action en fonction du mot après le premier espace du nom de l'onglet
    End Select
Next I 'prochain onglet de la boucle 1
End Sub

jmten92 · 5 Novembre 2016

ca marche un grand merci pouur ton aide
bon week end

XL 2013 extraction personnalisée + copie dans nouveau classeur du même répertoire

jmten92

XLDnaute Nouveau

Pièces jointes

Robert

XLDnaute Barbatruc

jmten92

XLDnaute Nouveau

Robert

XLDnaute Barbatruc

jmten92

XLDnaute Nouveau

Robert

XLDnaute Barbatruc

jmten92

XLDnaute Nouveau

Discussions similaires