Résolu Microsoft 365 automatiser macro pour copier/coller des données d´un classeur à un autre et sauver à chaque fois le classeur rempli

sevenkingdom

XLDnaute Nouveau
Bonjour,

Je dispose d´un tableau 579 colonnes *12 lignes avec des données à transférer dans un tableau d´un autre classeur.
Chaque colonne du 1er tableau a des valeurs différentes à transférer à chaque fois dans les mêmes cellules du second classeur ´test bestiaire.
Appliqué à une seule colonne B, j´obtiens une macro moche du type

Sub test()
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("B2").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B1").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("D10:D15").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B2:B7").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G40").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B8").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G38").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B9").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G41:G43").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B10:B12").Value
End Sub

Je copie les cellules B1 à B12 de mon 1er classeur vers les cellules de mon second classeur.

Je voudrais automatiser cette macro pour les 578 colonnes restantes et obtenir au final 579 tableaux (579 fichiers avec comme nom, les intitulés de la ligne 1, et en csv)

J´ai également ¨cassé¨ mon tableau 1 en 579 fichiers xls (format identique pour tous, 2 colonnes 12 lignes, mais ce coup ci toutes les données à copier sont dans la colonne B1:B12 de chaque fichier) pour appliquer cette macro, mais le problème est décalé (comment appliquer alors 1 macro à 579 fichiers différents??)


J´avais fait cette macro adaptée d´une macro trouvée sur un site

Sub test()
Dim i&, TTmp As Variant, Tdate As Variant, Tst$
Dim F As Worksheet, D As Object
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Feuil1")
Tdate = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3))
For i = 2 To .Cells(2, .Columns.Count).End(1).Column Step 1
TTmp = .Range(.Cells(1, i), .Cells(UBound(Tdate, 1), i + 0))
On Error Resume Next
Tst = Replace(TTmp(1, 1), "/", "-")
Tst = Left(Tst, 30)
Set F = Sheets(Tst)
If Err Then
Err.Clear
Sheets.Add(After:=Sheets(Sheets.Count)).Name = Tst
D(TTmp(1, 1)) = ""
Set F = Sheets(Tst)
End If
If Not D.exists(F.Name) Then
F.Range(F.Cells(1, 1), F.Cells(F.Rows.Count, 1).End(3)(1, 6)).ClearContents
D(F.Name) = ""
End If
F.Cells(1, 1).Resize(UBound(Tdate, 1), 1) = Tdate
F.Cells(1, 2).Resize(UBound(Tdate, 1)) = TTmp
F.Columns.AutoFit
F.Move

Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("B2").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B1").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("D10:D15").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B2:B7").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G48").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B8").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G46").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B9").Value
Workbooks("test bestiaire.xlsm").Worksheets("Feuil1").Range("G49:G51").Value = Workbooks("bestiaire.xlsm").Worksheets("Feuil1").Range("B10:B12").Value

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "dd_mm_yyyy") & "_" & ActiveSheet.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close False
Err.Clear
Next i
.Activate
End With
Application.DisplayAlerts = True
End Sub


Elle m a permis de séparer mon 1er classeur en 579 fichiers .csv mais ,évidemment, seules les données de la colonne B ont été copiées dans le classeur 2.

Donc comment faire pour transférer les données de B1:B12 du classeur 1 sur les bonnes cellules du classeur 2 puis sauver (en csv avec le nom de B1) le classeur 2 rempli , et recommencer la même opération avec C1:C12 , puis D1:D12 etc

En espérant que vous pourrez m´aider.
 
Ce fil a été résolu! Aller à la solution…

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Sevenkingdom, et bienvenu sur XLD,
( utilisez les balises </> pour le code, c'est bien plus lisible )
Vous pouvez construire une macro de transfert comme celle ci dessous :
VB:
Sub TransfertDonnées(Colonne As Integer)     ' C numéro de colonne à transferer
' tranfert des données de bestiaire.xlsm de Colonne vers test bestiaire.xlsm
    Set WF = Workbooks("test bestiaire.xlsm").Worksheets("Feuil1")
    Set RF = Workbooks("bestiaire.xlsm").Worksheets("Feuil1")
    WF.Range("B2").Value = RF.Cells(1, Colonne)
    WF.Range("G48").Value = RF.Cells(8, Colonne)
    WF.Range("G46").Value = RF.Cells(9, Colonne)
    WF.Range("D10:D15").Value = RF.Range(Cells(2, Colonne), Cells(7, Colonne)).Value
    WF.Range("G49:G51").Value = RF.Range(Cells(10, Colonne), Cells(12, Colonne)).Value
End Sub
L'appel dans le module principal se fait de cette façon :
Code:
Sub Essai()
Dim C As Integer
For C = 2 To 579    ' Pour les colonnes de 2 à 579
' Preparer fichier
' .....
' Transferer données
    TransfertDonnées C  ' On lance le transfert de la colonne C
' Enregistrer csv
' ...
Next C
End Sub
dans le module principal il faut gérer la colonne à transferer, puis faire appel à la macro de transfert.
c'est une méthode simple et robuste.
 

sevenkingdom

XLDnaute Nouveau
Bonjour. Merci pour la réponse.
Mais, si je comprends bien la 1ere macro, je ne comprends pas la suite. Où placer la macro sub transfertdonnées dans sub essai()? Ce sont deux macros différentes ?

Les éléments qui suivent ' sont explicatifs et pas à copier dans la macro ?
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Elle set appelée ici :
VB:
' Transferer données
    TransfertDonnées C  ' On lance le transfert de la colonne C
En fait j'aurais pu l'écrire :
Code:
' Transferer données
    Call TransfertDonnées (C)  ' On lance le transfert de la colonne C
mais je suis fainéant et ça alourdit la lecture inutilement
 

sevenkingdom

XLDnaute Nouveau
Bonjour
J ai essayé et il y a sûrement quelque chose que je fais mal. Je suis novice en langage VBA. j ai bien obtenu le transfert de la colonne B de bestiaire.xlsm sur l´autre classeur mais, pour le reste, j ai juste obtenu un fichier 26_07_2020_Feuil1.csv contenant mon fichier bestiaire en .csv ... et maintenant je n obtiens même plus rien...

j ai entré cela et j obtiens un message d erreur ...

VB:
Sub TransfertDonnées(Colonne As Integer)     ' C numéro de colonne à transferer
' tranfert des données de bestiaire.xlsm de Colonne vers test bestiaire.xlsm
    Set WF = Workbooks("test bestiaire.xlsm").Worksheets("Feuil1")
    Set RF = Workbooks("bestiaire.xlsm").Worksheets("Feuil1")
    WF.Range("B2").Value = RF.Cells(1, Colonne)
    WF.Range("G48").Value = RF.Cells(8, Colonne)
    WF.Range("G46").Value = RF.Cells(9, Colonne)
    WF.Range("D10:D15").Value = RF.Range(Cells(2, Colonne), Cells(7, Colonne)).Value
    WF.Range("G49:G51").Value = RF.Range(Cells(10, Colonne), Cells(12, Colonne)).Value
End Sub

Sub Essai()
Dim C As Integer
For C = 2 To 579
Call TransfertDonnées(C)

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "dd_mm_yyyy") & "_" & ActiveSheet.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
            ActiveWorkbook.Close False
            Err.Clear
    
      
Next C
End Sub
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Dans votre code les fichiers sauvegardés portent toujours le même nom ?
En PJ un essai.
Je ne sauvegarde que 10 fichiers ( à modifier )
J'écrase le fichier s'il existe déjà, peut être modifié.
 

Fichiers joints

sevenkingdom

XLDnaute Nouveau
Ca fonctionne (vous n´en doutiez pas) et merci mille fois. En plus il y a des explications et cela permet de comprendre ce qui se passe!

Mais il faudrait 2 améliorations.

que le nom du fichier créé correspondent au nom de la cellule 1 (B1 C1 du bestiaire etc) ou à celui de la cellule B2 du fichier créé.

que le fichier soit enregistré en csv sans colonne

Si je remplace
Code:
SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd_mm_yyyy") & "_" & ActiveSheet.Name & "_" & C & ".csv"
par
,
VB:
SaveAs ThisWorkbook.Path & "\" & Format(Date, "dd_mm_yyyy") & "_" & ActiveSheet.Name & ".csv", FileFormat:=xlCSV,
Encore merci!
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Essayez ça si j'ai bien compris la problématique.
J'ai rajouté la mesure de temps car avec plus de 500 fichiers, l'utilisateur va devoir patienter. :)
 
Ce message a été identifié comme étant une solution!

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas