Microsoft 365 Optimiser export données vers nouveau classeur

[Ludwig74]

Bonsoir tout le monde,

J'ai fait ce code qui me permet de copier une plage de données vers un nouveau classeur.
La plage de données se comporte de plusieurs colonnes dont certaines sont masquées. Les données masquées ne doivent pas être exportées.
Je boucle tout d'abord dans la colonne fournisseur.

Avec le nom du fournisseur :

• Je filtre la plage,
• je copie la plage,
• j'ouvre un nouveau classeur,
• je colle la plage,
• J'incrémente les photos en fonction des références,
• Je ferme en enregistrant le nouveau classeur : Commande + nom fournisseur + date + heure.

Ensuite, je continue ma boucle sur la colonne fournisseur et si nouveau fournisseur je crée à nouveau un classeur et ainsi de suite.

Ce code fonctionne correctement mais j'aimerais l'optimiser (ex enlever les mouvements d'écran dûs notamment aux créations des classeurs). Donc si une âme charitable passe par là.

J'avais dans l'idée, dans un premier temps, de lister les données dans un tableau, filtrer les fournisseurs sans doublon et ensuite de créer autant de fichiers que de fournisseurs. Enfin, incrémenter les données et les photos dans les classeurs fermés.
Mais ça, je ne sais pas faire. Mes tentatives ont échouées et m'ont conduit au code ci-dessous.

J'ai mis en pièce jointe les fonctions persos utilisées et un fichier exemple sans macro.

Par avance merci d'avoir pris le temps de me lire et prendre le temps de me répondre.

Ludwig

Dim Wb As String
Dim Nf As String

Sub BonCommande()

Dim Chemin As String
Dim NomFichier As String
Dim NomFour As String
Dim dl As Long

Wb = ActiveWorkbook.Name
Nf = ActiveSheet.Name

dl = DerniereLigne(Wb, Nf, 1)

With Application
   .ScreenUpdating = False
   .EnableEvents = False
   .Calculation = xlManual
End With

  If Not MsgBox("Voulez-vous valider le panier et générer les bons de commande ?", vbYesNo) = vbYes Then GoTo fin
 
  Call Tri(Wb, Nf, 1, "Nom fournisseur", "Référence Cabi")  'Tri la feuille
    
    For k = 2 To dl 'Boucle sur les noms de fournisseur
      
      NomFour = Cells(k, RechercheC(Wb, Nf, 1, "Nom fournisseur"))
      
      If Not NomFour = Cells(k - 1, RechercheC(Wb, Nf, 1, "Nom fournisseur")) Then 'Si nouveau fournisseur
      
        Cells(1, 1).AutoFilter 'Ajoute les filtres
        
        plage(Wb, Nf, 1).AutoFilter Field:=4, Criteria1:=NomFour 'Filtre sur le fournisseur
        
        Selection.CurrentRegion.Copy 'Copie le tableau filtré
        Workbooks.Add 'Ouvre un nouveau Classeur
        ActiveSheet.Paste 'Colle le tableau
        Application.CutCopyMode = False
        
        ImageBonCommande 'Incrémente les photos
        
        Chemin = "C:\Users\....\Commande fournisseur"
        ChDir (Chemin)
        NomFichier = "Commande " & NomFour & " du " & Format(Date, "ddmmyyyy") & " " & Format(Time, "hhmmss") & ".xlsx"
        ActiveWorkbook.SaveAs Filename:= _
            Chemin & "\" & NomFichier _
            , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Enregistre le nouveau classeur
            
        ActiveWindow.Close 'Ferme le classeur
        
      End If
      
      Cells(1, 1).AutoFilter 'Enlève les filtres
      
    Next k
            
  plage(Wb, Nf, 1).ClearContents 'Supprime le panier
  ListeC(Wb, "TSI", 1, "En commande").ClearContents
  ListeC(Wb, "Consolidation", 1, "En commande").ClearContents
 
fin:

With Application
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = xlCalculationAutomatic
End With
 
End Sub

 

[Ludwig74]

Bonjour à tous,

Après une longue soirée à chercher une solution, voici où j'en suis. cf code ci-dessous.
Deux problématiques :

• N'incrémente pas les lignes que d'un fournisseur. Sauf pour la première boucle. Je pense qu'il faudrait purger la table après la 1ère boucle. J'ai testé

  erase TabData

  mais provoque une erreur au deuxième passage.
• Je n'arrive pas à incrémenter les photos avec ce code.

Encore merci de prendre le temps de me lire.

Bonne journée

Ludwig

Sub ExportDonnées()

Dim Nvex As Object
Dim Wb As String
Dim Nf As String
Dim Nvwb As Object
Dim Nvf As Object
Dim dl As Long
Dim dc As Integer
Dim TabEntete As Variant
Dim txt As String
Dim r As Integer
Dim nb As Long
Dim TbData As Variant
Dim dlnvcl As Long

'Créer un nouveau classeur
Set Nvex = CreateObject("Excel.Application")
Set Nvwb = Nvex.Workbooks.Add

Wb = ActiveWorkbook.Name
Nf = ActiveSheet.Name

On Error GoTo er

With Application
   .ScreenUpdating = False
   .EnableEvents = False
   .Calculation = xlManual
End With

dl = dlg(Wb, Nf, 1, "Référence Cabi")

'Compte le nombre de colonne non masquée
  For i = 1 To Dcl(Wb, Nf, 1)
    If Columns(i).Hidden = False Then
      dc = dc + 1
    End If
  Next i

'Liste les fournisseurs sans doublon
Set ListeFour = CreateObject("Scripting.Dictionary")
  For Each c In ListeC(Wb, Nf, 1, "Nom fournisseur")
    ListeFour.Item(c.Value) = ListeFour.Item(c.Value) + 1
    nb = ListeFour.Count
  Next c

  TabEntete = Array("Référence Cabi", "Nom fournisseur", "Libellé", "Photo", "Pa net", "PVP", "Poids", "Taille", "Propo cmd", "Valo cmd")
    
  ReDim tabdata(1 To dl, 1 To dc) As Variant 'Créer un tableau

  For k = 0 To nb - 1 'Boucle sur les différents fournisseurs de ma table ListFour

    NomFour = ListeFour.keys()(k)
  
    For r = 1 To dl 'Boucle sur les lignes du classeur
    tt = Cells(r, RechC(Wb, Nf, 1, "Nom fournisseur"))
      If Cells(r, RechC(Wb, Nf, 1, "Nom fournisseur")) = NomFour Then 'Si le fournisseur est égal au 1er item de la liste des fournisseurs
        For c = 1 To dc 'Boucle sur les colonnes
          txt = TabEntete(c - 1)
          tabdata(r, c) = Cells(r, RechC(Wb, Nf, 1, txt))
        Next
      End If
    Next
  
    Set Nvf = Nvwb.Worksheets(1)  'Transfert le tableau dans le nouveau classeur
      With Nvf
        .Cells(1, 1).Resize(dl, dc).Value = tabdata
        .Range(.Cells(1, 1), .Cells(1, dc)).Value = TabEntete
      End With
  
      Chemin = "C:\Users\...\Commande fournisseur\" 'Sauvegarde le nouveau fichier
      NomFichier = "Commande " & NomFour & " du " & Format(Date, "ddmmyyyy") & " " & Format(Time, "hhmmss") & ".xlsx"
      Nvwb.SaveAs Chemin & NomFichier
   erase TabData 
  Next

  Nvex.Quit

With Application
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = xlCalculationAutomatic
End With

  MsgBox ("La commande est validée")
  Exit Sub
er:
  MsgBox ("Erreur")
  Nvex.Quit

End Sub