Macro Copier/Coller dans autre fichier excel sous condition

StagiaiireVannes

XLDnaute Nouveau
Bonjour à tous,

Voilà je viens de recevoir un fichier de plus de 20 000 lignes. J'ai refait la structure que vous trouverez en annexe.

Si quelqu'un peut m'aider, il faudrait une macro ou autres qui permettre de créer des fichiers Excel par fournisseur.
Je m'explique.
En colonne D on a un code fournisseur et en colonne E son libellé. Chaque founisseur a un unique code.
Il faudrait donc une macro qui copie/ colle les lignes par exemple pour le fournisseur A dans un autre fichier excel qui porterait comme nom la colonne E (le libellé).
A savoir les codes fournisseurs varient. (Il passe de 8 à 15 à 150 ...)
En gros il faudrai une boucle qui trie d'abord sur cette colonne et à chaque nouveaux code fournisseurs créer un nouveau classeur.

A la fin on aura donc un même nombre de classeur que de fournisseurs.

Merci à la personne qui prendra le temps de m'aider :)
Et si ce que j'ai dit n'est pas compréhensible, n'hésiter pas ) me poser des quesitons ^^
 

Fichiers joints

Robert

XLDnaute Barbatruc
Bonjour le forum,

Pas sûr que ce code fonctionne avec un tableau aussi grand. À tester :

VB:
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim F As String 'déclare la variable F (Fichier)
Dim TEST As Boolean 'déclare la variable TEST
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
  D(TV(I, 5)) = "" 'alimente le dictionnaire D avec la donnée en colonne 5 (le fournisseur) de la boucle
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
  F = Dir(CA & "*.xlsx") 'définit le fichier F (premier fichier .xlsx du dossier ayant CA comnme chemin d'accès)
  Do While F <> "" 'exécite tant qu'il existe des fichiers F
  If F = TMP(J) & ".xlsx" Then 'condition : si F est l'élément TMP(J) de la boucle 1
  Set CD = Workbooks.Open(CA & F) 'définit la classeur destination CD (en l'ouvrant)
  TEST = True 'définit la variable TEST
  GoTo suite 'va a l'étiquette "suite"
  End If 'fin de la condition
  F = Dir 'redéfinit la fichier F (fichier suivant du dossier ayant CA comme chemin d'accès)
  Loop 'boucle
  If TEST = False Then 'condition : si TEST est [faux]
  Application.SheetsInNewWorkbook = 1
  Set CD = Workbooks.Add(xlWBATWorksheet)  'ouvre un fichier vierge d'un seul onglet
  CD.SaveAs (CA & TMP(J)) 'renomme le fichier
  End If 'fin de la condition
suite: 'étiquette
  TEST = False 'reinitialise la variable TEST
  Set OD = CD.Worksheets(1) 'définit l'onglet destination DEST
  OD.Name = TMP(J) 'renomme l'onglet
  OD.Rows.Delete 'supprime toutes les lignes de l 'onglet OD
  OS.Rows(1).Copy OD.Range("A1") 'copy la première ligne
  K = 1 'initialise la variable K
  For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les ligne I du tableau des valeurs TV
  If TV(I, 5) = TMP(J) Then 'condition : si la donnée en colonne 5 de la boucle 2 vaut l'élément TMP(J) de la boucle 1
  ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
  For L = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonnes du tableau des valeurs TV
  TL(L, K) = TV(I, L) 'renvoie dan sla ligne L de TL la donnée en colonne L de TV (=> transposition)
  Next L 'prochaine colonne de la boucle 3
  K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
  End If 'fin de la condition
  Next I 'prochaine ligne de la boucle
  OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'renvoie dans DEST redimensionnée de le tableau TL transposé
  CD.Close True 'ferme le classeur destination en enregistrant les modifications
Next J 'prochain élément de la boucle 1
End Sub
Heu... Non il ne copie pas les formats...
 

StagiaiireVannes

XLDnaute Nouveau
Bonjour le forum,

Pas sûr que ce code fonctionne avec un tableau aussi grand. À tester :

VB:
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim F As String 'déclare la variable F (Fichier)
Dim TEST As Boolean 'déclare la variable TEST
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
  D(TV(I, 5)) = "" 'alimente le dictionnaire D avec la donnée en colonne 5 (le fournisseur) de la boucle
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
  F = Dir(CA & "*.xlsx") 'définit le fichier F (premier fichier .xlsx du dossier ayant CA comnme chemin d'accès)
  Do While F <> "" 'exécite tant qu'il existe des fichiers F
  If F = TMP(J) & ".xlsx" Then 'condition : si F est l'élément TMP(J) de la boucle 1
  Set CD = Workbooks.Open(CA & F) 'définit la classeur destination CD (en l'ouvrant)
  TEST = True 'définit la variable TEST
  GoTo suite 'va a l'étiquette "suite"
  End If 'fin de la condition
  F = Dir 'redéfinit la fichier F (fichier suivant du dossier ayant CA comme chemin d'accès)
  Loop 'boucle
  If TEST = False Then 'condition : si TEST est [faux]
  Application.SheetsInNewWorkbook = 1
  Set CD = Workbooks.Add(xlWBATWorksheet)  'ouvre un fichier vierge d'un seul onglet
  CD.SaveAs (CA & TMP(J)) 'renomme le fichier
  End If 'fin de la condition
suite: 'étiquette
  TEST = False 'reinitialise la variable TEST
  Set OD = CD.Worksheets(1) 'définit l'onglet destination DEST
  OD.Name = TMP(J) 'renomme l'onglet
  OD.Rows.Delete 'supprime toutes les lignes de l 'onglet OD
  OS.Rows(1).Copy OD.Range("A1") 'copy la première ligne
  K = 1 'initialise la variable K
  For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les ligne I du tableau des valeurs TV
  If TV(I, 5) = TMP(J) Then 'condition : si la donnée en colonne 5 de la boucle 2 vaut l'élément TMP(J) de la boucle 1
  ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
  For L = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonnes du tableau des valeurs TV
  TL(L, K) = TV(I, L) 'renvoie dan sla ligne L de TL la donnée en colonne L de TV (=> transposition)
  Next L 'prochaine colonne de la boucle 3
  K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
  End If 'fin de la condition
  Next I 'prochaine ligne de la boucle
  OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'renvoie dans DEST redimensionnée de le tableau TL transposé
  CD.Close True 'ferme le classeur destination en enregistrant les modifications
Next J 'prochain élément de la boucle 1
End Sub
Heu... Non il ne copie pas les formats...

Malheureusement, ca ne marche pas pour moi :/
 

StagiaiireVannes

XLDnaute Nouveau
Bonjour
Tu peux essayer ceci. Les fichiers sont enregistrés dans le répertoire du fichier test
La macro a très bien commencé , mais je ne sais pas pourquoi elle sait arreter vers la ligne 300 et a reprit après à la ligne 1 707 jusqu'à la fin.
De plus j'aimerais savoir si c'est possible de garder la première ligne du tableau sur les différents fichiers Excel ? :)
 

sousou

XLDnaute Accro
Re
Avec la ligne 1
Pour le reste qu'appelles-tu (la macro s'arrete? si elle s'arrete je ne vois pas comment elle peut reprendre seule
Tu peux essayer d'envoyer l'exemple avec les 400 premières lignes
 

Fichiers joints

sousou

XLDnaute Accro
RE
Le problème vient du libellé du fournisseur.
02 - BRIOCH/VIENN.THOMAS BVP dans l'exemple
Il est impossible d'avoir un / dans le nom d'un fichier, puisque ce dernier représente le passage à un sous- répertoire.
J'ai donc ajouté une instruction remplaçant le / par -,
mais sur tes 20 000 lignes peut-être d'autre caractères interdits. Procéder de même pour éviter les caractères non valides
La modif
Sub fichier(lignes)

nfich = lignes.Cells(1, 5).Value
nfich = Replace(nfich, "/", "-") ' ici remplacement du /'
Application.StatusBar = nfich
Set newfich = Workbooks.Add()
lignes.Copy newfich.Sheets(1).Range("a2")
lignetitre.Copy newfich.Sheets(1).Rows(1)
newfich.SaveAs (ThisWorkbook.Path & "/" & nfich & ".xlsx")
newfich.Close
End Sub
 

Discussions similaires


Haut Bas