VBA Déplacer onglets selon conditions

Version imprimable

15/11/2019, 09h46
swiches

1 pièce(s) jointe(s)

VBA Déplacer onglets selon conditions

Bonjour a tous!

J'ai un fichier Excel avec plusieurs onglets:
1. menu
2. données 1
3. données 2
4 etc...

dans l'onglet menu, j'ai un tableau, dans lequel j'indique des groupements de données. Je m'explique:

La 1ere colonne indique un nom de groupement
La 2eme colonne indique le nom des onglets concernés, séparé par un ";"

Ce que je n'arrive pas à faire, c'est une macro, qui lit le tableau, et me creer un nouveau classeur pour chaque groupement, et copie chaque onglet référencé de ce groupement, dans le nouveau classeur concerné.

en PJ mon fichier, il contient déja des macro qui aident a préparer mes données.

J'ai vraiment besoin de votre aide. merci beaucoup si vous pouvez me l'apporter !

Bonjour swiches, Bonjour le Forum,

Pas d'ouverture de pièce jointe en début de discussion.

Si le nom des onglets figurent sur une seule cellule, alors tu peux utiliser la fonction Split.
La résultante en sera un tableau Array - à 1 dimension - que tu peux parcourir

Exemple à adapter (adresse, type de fichier enregistré...):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Option Explicit
 
Public Sub créat_wkb()
 
Dim derlign As Long
Dim c As Range
Dim wkb_destin As Workbook
Dim s As Variant
Dim i As Integer
 
Application.ScreenUpdating = False
 
With Worksheets("Menu")
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each c In .Range("A1:A" & derlign)
                Workbooks.Add
                ActiveWorkbook.SaveAs Filename:=c.Value & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
                Set wkb_destin = ActiveWorkbook
                s = Split(c.Offset(0, 1).Value, ";")
                For i = LBound(s) To UBound(s)
                        ThisWorkbook.Worksheets(s(i)).Copy After:=wkb_destin.Worksheets(wkb_destin.Worksheets.Count)
                Next i
                Erase s
                Application.DisplayAlerts = False
                With wkb_destin
                        .Worksheets(1).Delete
                        .Close SaveChanges:=True
                End With
                Application.DisplayAlerts = True
                Set wkb_destin = Nothing
        Next c
End With
 
Application.ScreenUpdating = True
 
End Sub

Consulte ce code ligne à ligne pour le comprendre, essaie de l'adapter et reviens pour toute question éventuelle.

15/11/2019, 10h30
swiches

Ca marche nikel! merci beaucoup !
15/11/2019, 10h34
MarcelG

Salut,

Je viens d'apporter quelques retouches.

S'il te plaît, ne te contente pas d'un simple copier/coller.
Il serait opportun, en effet, que tu intègres toutes les méthodes et propriétés reportées dans le code proposé.
Bien entendu, tu peux revenir pour toute question.