VBA - Copié collé selon conditions
Bonjour,
Je viens demander un peu d'aide pour la réalisation de ma macro qui effectue la synthèse de 50 fichiers que je reçois chaque jour au format identique.
J'ai réussi à réaliser la plus grosse partie en m'inspirant énormément sur internet (je n'ai aucune connaissance en VBA par contre je maitrise pas mal de formule excel mais je n'arrive pas à faire le lien entre les deux et mes connaissances ).
Je vous explique le principe et ensuite mon problème Je reçois ces 50 fichiers et pour le moment ma macro arrive à recopier le contenu de chaque fichier sur une feuille synthèse les uns à la suite des autres.
Ce que j'essaye de faire maintenant c'est dans la cellule $A$1 il y a un texte dans lequel il y a une date et un numéro qui m’intéresse.
J'ai pour l'instant que réussit à récupérer ces informations avec la formule Left et Right sur VBA malheureusement j'aimerai
1. que cette date et ce numéro ne soient pas copiés si aucune information n'est présente sur la cellule B6
2. que cette date et ce numéro soient copiés plusieurs fois si des informations sont présentes sur B6+n (B7, B8, B9 etc....) jusqu'à retrouver aucune donnée
J'arrive à le faire au format excel =si(B6="";""; Droite($A$1; 10) pour la date et =si(B6="";""; Droite(Gauche($A$1; 28); 7) mais
j'aimerai pour des raisons de simplicité de fichier l'intègrer dans ma macro
Merci à vous
P.S. : Ci-joint 3 document ( 1 la synthèse et 2 fichier type)
Sheets("RapportPersonnel").Select
If Not IsEmpty(Range("B6")) Then
J'ai trouvé ça entre temps pour récupérer la date et le numéro que sur les documents remplis mais je trouve toujours pas comment le faire en N+1
Bonjour,
J'ai continué à avancer de mon côté j'arrive maintenant à afficher la date et le numéro avec une méthode un peux barbare mais c'est fonctionnel
J'ai encore un problème je n'arrive pas à enlever les 0 qui s'accumulent au bas de mes données quand je lance la macro
Sheets("RapportPersonnel").Select
If Not IsEmpty(Range("B6")) Then
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("RapportPersonnel").Select
Range("A1:P1").Select
Selection.Copy
Range("A37").Select
ActiveSheet.Paste
Range("A38").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,10)"
Range("A39").Select
ActiveCell.FormulaR1C1 = "=RIGHT(LEFT(R[-2]C,28),7)"
With Sheets("RapportPersonnel")
.Cells(38, 1).Copy .Range(.Cells(6, 1), .Cells(.Rows.Count, 2).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)
OS.Range("A6:A34").Copy DEST
.Cells(39, 1).Copy .Range(.Cells(6, 19), .Cells(.Rows.Count, 2).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "S").End(xlUp).Offset(1, 0)
OS.Range("R6:R34").Copy DEST
End With
End IfJe vous remet le fichier en pièce jointe
Bonjour,
Personne pour me donner un petit coup de main, j'ai fait quelque chose de mal
J'ai continué a avancer de mon côté l'intégralité de mon code ressemble a ceci :
Sub CreationSynthese()
' Ouverture de l'onglet :
With Sheets("Personnel")
.Activate
End With
' Nettoyage du fichier :
Range("A4:S100000").Select
Selection.ClearContents
Dim BDD As FileDialog 'déclare la variable BDD (Boîte de Dialogue Dossier)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim FS As String 'décalre la variable FS (Fichier Source)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (celllue de DESTination)
'définit la boîte de dialogue BDD (permetant de définit le dossier des fichiers source)
Set BDD = Application.FileDialog(msoFileDialogFolderPicker)
With BDD 'prend en compte BDD
.AllowMultiSelect = False 'n'autorise qu'une seule sélection
.Show 'affiche BDD
If .SelectedItems.Count = 0 Then Exit Sub 'si bouton [Annuler], sort de la procédure
CA = .SelectedItems(1) & "\" 'définit la chemin d'accès CA aux fichiers à ouvrir
End With 'fin de la prise en compte de BDD
'fin des lignes à supprimer si...
Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Sheets(1) 'définit l'onglet destination OD (à adapter à ton cas, ici j'ai mis le premier onglet)
FS = Dir(CA & "*.xlsx") 'définit le premier fichier source Excel contenu dans le dossier ayant CA comme chemin d'accès
Do While FS <> "" ' exécute tant qu'il existe des fichiers source
Workbooks.Open CA & FS 'ouvre le fichier source FS
Set CS = ActiveWorkbook 'définit la classeur source CS
Set OS = CS.Worksheets("RapportPersonnel") 'définit l'onglet source OS (à adapter à ton cas, ici j'ai j'ai mis le premier onglet)
'*******************************************************************************************
'définit la cellule de destination DEST (première cellule vide de la colonne A)
Set DEST = OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)
OS.Range("A6:Q34").Copy DEST 'copie la plage A6:Q34 de l'onglet source et la colle dans DEST
'copie la date et le N° de chantier
Sheets("RapportPersonnel").Select
If Not IsEmpty(Range("B6")) Then
Range("A37").Select
ActiveCell.FormulaR1C1 = "=RIGHT(R[-36]C,10)"
Range("A38").Select
ActiveCell.FormulaR1C1 = "=RIGHT(LEFT(R[-37]C,28),7)"
With Sheets("RapportPersonnel")
.Cells(37, 1).Copy .Range(.Cells(6, 1), .Cells(.Rows.Count, 2).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)
OS.Range("A6:A34").Copy DEST
.Cells(38, 1).Copy .Range(.Cells(6, 19), .Cells(.Rows.Count, 2).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "S").End(xlUp).Offset(1, 0)
OS.Range("R6:R34").Copy DEST
End With
End If
'*******************************************************************************************
CS.Close False 'ferme le claseru source CS (sans enregistrer)
FS = Dir 'définit le prochain fichier source excel du dossier ayant CA comme chemin d'accès
Loop 'boucle
End SubJ'ai toujours un problème de 0 qui apparait sans raison et les dates et numéro de chantier que je copie m'affiche problème REF, j'ai essayé d'incrémenter .PasteSpecial Paste:=xlPasteValues mais je sais pas trop comment
Si une âme charitable pouvait m'apporter un peux de sont temps je le remerciait grandement
Cordialement
Bonjour Tofover,
Voir dans les deux feuilles sources Fichier Prise d'information ( et 2) à partir de la ligne 13 jusqu'à 34 de la colonne I. La présence de formules s'appuyant sur les colonnes précédentes.
En fait en copiant à partir de ce code
'définit la cellule de destination DEST (première cellule vide de la colonne A)
Set DEST = OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)
OS.Range("A6:Q34").Copy DEST 'copie la plage A1:H50 de l'onglet source et la colle dans DESTTu amènes ces formules dans ta feuille de synthèse (avec un décalage colonne). Comme les colonnes précédentes sont vides, la formule renvoie 0. Soit tu supprimes ces formules (si inutiles) dans tes fichiers sources ou sinon tu adaptes.
A suivre...
Bonjour,
Merci pour ton message je vois maintenant pourquoi les 0 sont affiché à la fin de mon tableau je n'avait pas fait attention au formule dans ma prise d'info je vais essayer de solutionner cela, en ce qui concerne les dates j'ai aussi trouvé une solution en faisant un copié collé de valeur sur la feuille source avant de la copié sur la feuille destination ce qui me donne :
'copie la date et le N° de chantier
Sheets("RapportPersonnel").Select
If Not IsEmpty(Range("B6")) Then
Range("A37").Select
ActiveCell.FormulaR1C1 = "=RIGHT(R[-36]C,10)"
Application.CutCopyMode = False
Selection.Copy
Range("B37").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A38").Select
ActiveCell.FormulaR1C1 = "=RIGHT(LEFT(R[-37]C,28),7)"
Selection.Copy
Range("B38").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Sheets("RapportPersonnel")
.Cells(37, 2).Copy .Range(.Cells(6, 1), .Cells(.Rows.Count, 3).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)
OS.Range("A6:A34").Copy DEST
.Cells(38, 2).Copy .Range(.Cells(6, 19), .Cells(.Rows.Count, 3).End(3)(1, 0))
Set DEST = OD.Cells(Application.Rows.Count, "S").End(xlUp).Offset(1, 0)
OS.Range("R6:R34").Copy DEST
End WithJe pense mon programme plutôt aboutit malgré les barbaries y'aurait t'il des point d'amélioration afin d'optimiser la macro ?
A nouveau,
Je peux regarder en fonction des 2 fichiers sources copiés. Mais il faudrait des fichiers bien différents en données pour voir si cela tourne correctement.
Là sur 2 fichiers on ne peut faire une généralité.
Il est peut être possible de faire plus concis. Il faut voir avec plus de données. On se rend mieux compte.
À suivre...
Bonjour,
J'ai fait 4 fichiers source du coup pour avoir un peux plus de donnée, dis moi si cela n'est pas suffisant je rajouterai plus de fichier
Merci
Bonjour Tofover,
J'ai déjà commencé à modifier toute la partie haute de la macro afin de la réduire.
Je regardes ton dernier envoi.
À suivre...
Bonjour Tofover,
Voici une proposition pour ton fichier Synthèse. Vois les modifs faites sur la macro de même nom concernée.
Et les notes apportées en commentaires dans cette macro.
Bons tests, bonne continuation.
Bonjour X Cellus,
Ta proposition est très intéressante pour moi elle me permet de gagner un temps considérable sur la macro (environ 2 min de gagner sur 250 fichier récupéré donc passage de 4 minute de macro a seulement 2)
Je n'ai plus de zéro à la fin de mon fichier merci
La partie pour récupéré le N° de chantier est fonctionnel mais pas celle pour la date de chantier (je pense que cela est dû à la présence d'une lettre dans le N° de chantier empêchant la transformation de la cellule alors que la date elle n'est composé que de chiffre, en plus les cellules sur mon fichier source sont au format monétaire et je ne peux pas le modifier)
J’obtiens après la macro des dates en euro (43 565€)
Piste possible de modification (après je sais pas mettre en forme ^^) :
Sheet1.Cell("A1").Value = Sheet1.Cell("B1").Value Sinon je compte remettre ce que j'avais fait pour la date mais c'est pas optimisé car la macro prend 1 minute de plus par rapport à ton fichier
Bonjour Tofover,
Je crois avoir oublié dans mes commentaires que lorsque tu copies la date de A1 en B38. La cellule B38 doit être formatée en date auparavant.
Ce que j'ai fait pour tes fichiers envoyés. Mais dans les fichiers que tu utilises. Cette cellule B38 est en format numérique ou monétaire. Et donc tu renvoie ce format dans la feuille de synthèse.
Donc en modifiant le format dans tes fichiers sources de cette cellule. Tu enverras lors de la copie un format date dans la colonne A en feuille synthèse.
Tu n'auras plus ainsi le format numérique de la date affiché en colonne A.
Et ravi de t'avoir fait gagner du temps.
Non tu n'a pas oublié dans ton commentaire de le justifier, j'avais bien compris le fonctionnement de ta macro et le petit point de blocage (format de cellule) mais ce fichier source justement je ne peux pas y touché donc je ne pourrais pas obtenir la date au final
A nouveau,
Compte tenu que tu fermes chaque fichier source lu sans enregistrement.
Tu peux alors juste avant la récupération de la cellule A1 en partie. Faire un formatage de la cellule B37. Donc juste en dessous de ma ligne commentaire Note: toute la colonne...
Inscrit Range("B37"). NumberFormat="dd/mm/yyyy"
Ainsi cette cellule prendra un format de date avant que tu la transfert sur la feuille Synthèse. Sans que ce format perdure dans le fichier source car tu n'enregistre pas les modifs.
Donc au final tu auras la date et pas une valeur numérique.
Bonne continuation.
Encore moi désolé
Petit problème de compréhension pour ma part j'ai mieux compris en rajoutant la formule pas à pas que tu m'a envoyé.
J'arrive du coup à récupérer la date, par contre elle est sont au format US pour certaine mais pas d'autre
Range("B37").NumberFormat = "dd/mm/yyyy"
Range("B37") = Right([A1], 10): Range("B38") = Mid([A1], 22, 6)Aurait tu une solution à ce problème ?
Merci d'avance
A nouveau,
Cela vient de certains fichiers sources qui ont les jours inférieurs à 10. Donc qui débutent par un 0.
Lorsque ce zéro est supprimé la date s'affiche correctement au format "d/m/yyyy"
Je vais voir comment y remédier.
À suivre...
Suite,
Voici la modification réalisée. Je l'ai testée et cela sort correctement la date.
Range("B37").NumberFormat = "d/m/yyyy"
Range("B37") = Right("+" & [A1], 11): Range("B38") = Mid([A1], 22, 6)Le "+" permet de forcer en numérique dans la cellule B37 la date texte copiée d'après A1.
Dès lors le format numérique "d/m/yyyy" est appliqué sans souci.
Un petit + mais qui change tout...
Bonjour X Cellus,
Toujours la même chose avec excel à une virgule ou un point près on obtient pas le même résultats
J'ai pu tester ta modif, tous fonctionne parfaitement, je n'ai plus aucun point de blocage sur le codage de cette macro.
Je te remercie pour ta patience, ton temps et ton aide précieuse qui m'a permit du coup d'avoir une macro bien mieux optimisé et bien plus rapide (vitesse de la macro x2)
Bonne continuation à toi et encore merci