Bonjour à tous,

Je profite de ce mail pour remercier tous les "experts" qui contribuent à ce site car j'avoue y avoir trouver beaucoup beaucoup d'infos pour construire quelques unes des macros que j'utilise. Vous l'aurez compris, je bidouille de manière empirique. Merci pour votre indulgence.

Je coince sur un problème depuis le début du weekend et malgré un nombre incalculable de tentative, rien n'y fait et cela finit par me taper sur les nerfs! J'espère que vous pourrez m'aider (... j'en suis sûr!).

Mon problème : J'ai une macro qui sélectionne les 16 1ères feuilles d'un classeur (qui en contient en général 35/40) pour les enregistrer dans un nouveau classeur qui prendra le nom du 16ième onglets (ramené en 1ère position). Les 15 1ères sont toujours les mêmes mais le nom de la 16 ième varie à chaque fois. La macro fonctionne bien s/le 1er tour mais bloque à la deuxième boucle au niveau de la sélection des pages via MyArray().

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub b_TRIER_ONGLETS_et_SAVE_AS()
 
Application.ScreenUpdating = False
 
Dim boucle As Integer 'définition de la boucle de répétition
Dim NomOnglet As String
 
boucle = ThisWorkbook.Sheets.Count 'comptage nbre total onglets
Nbr_Onglets = boucle - 15 'comptage nbre kyc créé
 
Do Until Nbr_Onglets = 0 'boucle active tant que Nbr_Onglets > 0
 
    NomOnglet = Sheets(16).name
    MsgBox "Nom du classeur à créer : " & NomOnglet
 
    Dim WB1 As Workbook
    Dim MyArray() As String
    Dim i As Integer, X As Byte
 
    Set WB1 = ThisWorkbook
 
    For i = 1 To 16
        ReDim Preserve MyArray(X)
        MyArray(X) = Sheets(i).name
        X = X + 1
    Next
 
    WB1.Worksheets(MyArray).Copy '<==== le problème vient de là au second tour!!!
 
    Sheets(16).Move Before:=Sheets(1)
    SendKeys ("{ENTER}")    'Evite d'avoir le message de confirmation
    Sheets(Array("Liste", "Départ", "KYC Form")).Delete 'Efface les onglets inutiles
    Sheets(Array(2, 4, 6, 8, 9, 10)).Visible = False 'Masque les onglets
    Sheets(1).Activate
 
Dim Chemin As String, NomFichier As String
Dim Extension As String
 
  Extension = ".xlsm"
  Chemin = "D:\XBOAO_v2\Fiches OK\" 'indiquer le chemin pour enregistrer sous
 
  On Error GoTo 0
  NomFichier = Sheets(1).name & Extension
      With ActiveWorkbook
        .SaveAs Filename:=Chemin & NomFichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        .Close
        SendKeys ("{ENTER}")    'Evite d'avoir le message de confirmation
        Sheets(16).Delete  'Efface onglet traité
    End With
 
  Sheets("Départ").Range("A1:A4").Activate
 
  Sheets("Départ").Shapes("Image 3").Visible = True
  Sheets("Départ").Shapes("Image 6").Visible = True
 
Loop 'rebouclage
 
End Sub
Merci d'avance pour votre aide.

Cdt / Wynelle