Duplication de lignes suivant concaténation
Bonjour à tous et toutes,
Je me permets de faire ce sujet car je bloque sur la dernière partie de l'une de mes macros.
Le but de la macro est de vérifier que si la concaténation de l'onglet B (Traitement A rép) se trouve également dans l'onglet A (Traitement R) alors on duplique autant de fois sur l'onglet B le nombre de concaténation de l'onglet A trouvée. Pour ce faire j'ai déjà réalisé le code ci-dessous, avec en point de blocage le dernier bloc If qui n'est pas bon.
Sub AbsencesRécurrents()
Dim DerLigneAbs As Long
Dim DerLigneRécurrents As Long
With ThisWorkbook.Sheets("Traitement R")
DerLigneRécurrents = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
For i = 2 To DerLigneRécurrents
Range("C" & i).Value = Range("A" & i) & " " & Range("B" & i)
Next i
End With
With ThisWorkbook.Sheets("Traitement A rép")
DerLigneAbs = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
For i = 2 To DerLigneAbs
.Range("C" & i).Value = Range("A" & i) & " " & Range("B" & i)
.Range("A1:F1").AutoFilter Field:=2, Criteria1:=">=" & ThisWorkbook.Sheets("Accueil").Range("M1") 'Filtre sur la période afin d'avoir les mois supérieurs ou égaux à celui renseigné sur l'onglet Accueil en M1
If ThisWorkbook.Sheets("Traitement R").Range("C" & i) = .Range("C" & i) Then
.Rows(i).Copy
.Rows(i).Insert
.Range("D" & i).Value = ThisWorkbook.Sheets("Traitement R").Range("D" & i)
.Range("F" & i).Value = "=" & .Range("F" & i) & "*" & ThisWorkbook.Sheets("Traitement R").Range("E" & i)
End If
Next i
End WithVous trouverez en image ce que je souhaite obtenir ce qui sera plus parlant que mes explications. La première image représente les données brutes du fichier joint à ce sujet (à gauche les données de l'onglet A et à droite les données de l'onglet B)
Sur la seconde image, le résultat souhaité. La duplication des lignes sur l'onglet B devra reprendre les codes analytiques de l'onglet A et le % de répartition qui affectera la colonne "Variation Heures A".
J'espère avoir été assez clair afin d'obtenir votre aide à ce sujet. D'avance merci pour ceux qui se pencheront sur le problème.
Bonne journée
Bonjour,
Cette ligne là:
.Range("F" & i).Value = "=" & .Range("F" & i) & "*" & ThisWorkbook.Sheets("Traitement R").Range("E" & i)devrait s'écrire:
.Range("F" & i).Value = .Range("F" & i) * ThisWorkbook.Sheets("Traitement R").Range("E" & i)Mais pour des raisons de lisibilité, plutôt que de conserver les noms des feuilles en entier, mieux vaut passer par des variables, comme ceci:
Sub AbsencesRécurrents()
Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
Dim DerLigneAbs As Long
Dim DerLigneRécurrents As Long
Set f1 = Sheets("Accueil")
Set f2 = Sheets("Traitement R")
Set f3 = Sheets("Traitement A rép")
With f2
DerLigneRécurrents = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
For i = 2 To DerLigneRécurrents
f2.Range("C" & i).Value = f2.Range("A" & i) & " " & f2.Range("B" & i)
Next i
End With
With f3
DerLigneAbs = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
For i = 2 To DerLigneAbs
.Range("C" & i).Value = Range("A" & i) & " " & Range("B" & i)
.Range("A1:f2").AutoFilter Field:=2, Criteria1:=">=" & f1.Range("M1") 'Filtre sur la période afin d'avoir les mois supérieurs ou égaux à celui renseigné sur l'onglet Accueil en M1
If f2.Range("C" & i) = .Range("C" & i) Then
.Rows(i).Copy
.Rows(i).Insert
.Range("D" & i).Value = f2.Range("D" & i)
.Range("F" & i) = .Range("F" & i) * f2.Range("E" & i)
End If
Next i
End With
'If f3.FilterMode = True Then
' f3.ShowAllData
'End If
'
'f2.Columns(3).Delete
'f3.Columns(3).Delete
Set f1 = Nothing
Set f2 = Nothing
Set f3 = Nothing
End SubCdlt
Bonjour,
Je te remercie pour l'aide concernant la formule pour mon calcul en colonne F.
Malheureusement cela ne résout pas mon problème initial qui est de dupliquer les lignes avec le respect de la répartition en fonction de la concaténation. Ci-dessous le résultat que je souhaiterai obtenir.
Par exemple, dans l'onglet "Traitement R", je trouve deux lignes avec la concaténation "2222 202305" avec comme répartition 50% sur chacune des lignes de cet onglet. La macro devra donc créer autant de ligne sur l'onglet "Traitement A rép" si cette concaténation existe également tout en calculant la "Variation Heures A" en fonction de la répartition trouvée.
J'espère avoir été un peu plus clair sur ma demande, je joins de nouveau le fichier de base.
Bonne journée
Attention, je n'ai regardé que la ligne qui présentait un bug et corrigé ce bug, je n'ai pas cherché à analyser plus particulièrement votre code pensant que ce que vous aviez fait était correct. C'est du moins ce que j'ai compris en vous lisant:
Pour ce faire j'ai déjà réalisé le code ci-dessous, avec en point de blocage le dernier bloc If qui n'est pas bon.
Je peux regarder de plus près votre code, mais pas dans l'immédiat, alors patientez un peu, à moins que d'ici là, quelqu'un d'autre soit intervenu.
Cdlt
Arturo,
En effet je me suis mal exprimé au début de mon sujet.
Je ne suis pas pressé par le temps donc je peux attendre il n'y a pas de problème à cela sauf comme vous l'avez dit si quelqu'un intervient avant.
Bonne journée
Bonjour Arturo,
Merci beaucoup pour ton fichier, j'ai pu faire quelques tests avec un échantillon plus grand que celui du fichier joint et j'ai remarqué un problème.
En effet lorsque sur l'onglet "Traitement R" j'ai plus de 2 occurrences comme tu peux le voir sur la première image, l'exécution de la macro sur l'onglet "Traitement A rép" ne prend pas en compte les 4 occurrences mais seulement 2 (image 2).
Serait-il possible de faire des modifications en ce sens ? De plus serait-il possible de copier le motifs autant de fois que de ligne créée ?
Encore merci pour le temps passé sur le fichier jusqu'à maintenant et merci d'avance pour le temps passé sur mes nouvelles demandes.
Cordialement,
Bonjour,
Dans mon code précédent c'était prévu, mais j'ai fait une mauvaise manip.
Voici le code corrigé:
Option Explicit
Sub AbsencesRécurrents()
Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
Dim DerLigneAbs As Long, DerLigneRécurrents As Long, DerLig As Long, i As Long, Deb As Long
Dim Ref As String
Dim x As Range
'Déclaration des variables "Feuilles"
Set f1 = Sheets("Accueil")
Set f2 = Sheets("Traitement R")
Set f3 = Sheets("Traitement A rép")
'Effacement des filtres existants sur les 2 feuilles
If f2.FilterMode = True Then f2.ShowAllData
If f3.FilterMode = True Then f3.ShowAllData
With f2
DerLigneRécurrents = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).Value = Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).Value
End With
With f3
DerLigneAbs = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).Value = Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).Value
DerLig = DerLigneAbs
For i = 2 To DerLig
If .Cells(i, "B") >= f1.Cells(1, "M") Then
Ref = .Cells(i, "C")
'recherche de la même référence dans la feuille "Traitement R"
Set x = f2.Columns(3).Find(Ref)
If Not x Is Nothing Then
Deb = x.Row
Do
Range(.Cells(DerLigneAbs + 1, "A"), .Cells(DerLigneAbs + 1, "D")).Value = Range(f2.Cells(x.Row, "A"), f2.Cells(x.Row, "D")).Value
.Cells(DerLigneAbs + 1, "F") = .Cells(i, "F") * f2.Cells(x.Row, "E")
DerLigneAbs = DerLigneAbs + 1
Set x = f2.Columns(3).FindNext(x)
Loop While Not x Is Nothing And x.Row <> Deb
End If
.Cells(i, "F") = .Cells(i, "F") * f2.Cells(x.Row, "E")
End If
Next i
End With
'Tri
f3.Range("A2:F" & f3.Range("A1").CurrentRegion.Rows.Count + 1).Sort f3.Range("C1"), 1
f2.Columns(3).Delete
f3.Columns(3).Delete
'Libération de la mémoire
Set x = Nothing
Set f1 = Nothing
Set f2 = Nothing
Set f3 = Nothing
End SubCdlt
Arturo,
Nous nous approchons de la perfection sur le code (enfin toi puisque moi je n'avais pas réussi à faire ce que tu as fait) mais j'ai encore un dernier problème à régler.
Serait-il possible de supprimer la ligne de l'onglet "Traitement A rép" qui est dupliquée ? Comme tu peux le voir sur l'image les heures sont comptées en double si la ligne dupliquée n'est pas supprimée.
Encore merci pour ton aide sur cette macro
D'accord, mais si les codes ANA sont différents, on supprime quoi?
En fait il faudrait supprimer la première ligne que nous dupliquons, sur l'image cela serait la ligne à 147 heures puisque les quatre lignes à 36,75 heures sont les lignes souhaitées.
Est-ce cela?
Sub AbsencesRécurrents()
Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
Dim DerLigneAbs As Long, DerLigneRécurrents As Long, DerLig As Long, i As Long, Deb As Long
Dim Ref As String
Dim x As Range
'Déclaration des variables "Feuilles"
Set f1 = Sheets("Accueil")
Set f2 = Sheets("Traitement R")
Set f3 = Sheets("Traitement A rép")
'Effacement des filtres existants sur les 2 feuilles
If f2.FilterMode = True Then f2.ShowAllData
If f3.FilterMode = True Then f3.ShowAllData
With f2
DerLigneRécurrents = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).Value = Range(.Cells(2, "C"), .Cells(DerLigneRécurrents, "C")).Value
End With
With f3
DerLigneAbs = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).Value = Range(.Cells(2, "C"), .Cells(DerLigneAbs, "C")).Value
DerLig = DerLigneAbs
For i = 2 To DerLig
If .Cells(i, "B") >= f1.Cells(1, "M") Then
Ref = .Cells(i, "C")
'recherche de la même référence dans la feuille "Traitement R"
Set x = f2.Columns(3).Find(Ref)
If Not x Is Nothing Then
Deb = x.Row
Do
Range(.Cells(DerLigneAbs + 1, "A"), .Cells(DerLigneAbs + 1, "D")).Value = Range(f2.Cells(x.Row, "A"), f2.Cells(x.Row, "D")).Value
.Cells(DerLigneAbs + 1, "F") = .Cells(i, "F") * f2.Cells(x.Row, "E")
DerLigneAbs = DerLigneAbs + 1
Set x = f2.Columns(3).FindNext(x)
Loop While Not x Is Nothing And x.Row <> Deb
End If
Rows(i).Delete
DerLigneAbs = DerLigneAbs - 1
End If
Next i
End With
'Tri
DerLig = f3.Range("A1").CurrentRegion.Rows.Count
f3.Range("A2:F" & DerLig + 1).Sort f3.Range("C1"), 1
'Suppression des lignes en double
For i = DerLig To 2 Step -1
If f3.Cells(i, "C") = f3.Cells(i - 1, "C") Then Rows(i).Delete
Next i
f2.Columns(3).Delete
f3.Columns(3).Delete
'Libération de la mémoire
Set x = Nothing
Set f1 = Nothing
Set f2 = Nothing
Set f3 = Nothing
End SubBonjour Arturo,
Désolé je ne pouvais pas te répondre avant.
Malheureusement je me suis mal exprimé (encore une fois) et du coup le résultat de ton dernier code n'est pas celui souhaité.
Il faudrait supprimer les lignes "i", j'ai rajouté un Debug.Print pour connaître ces lignes "i".
Serait-il possible de stocker ces numéros de lignes pour les supprimer une fois la macro exécutée ?
Cordialement,
Bonjour,
Essayez ceci:
Option Explicit
Sub AbsencesRécurrents()
Dim Récurrents As Worksheet, Absences As Worksheet
Dim DerLigneAbs As Long, DerLigneRécurrents As Long, DerLig As Long, i As Long, Deb As Long, k As Long, Lig As Long
Dim Concaténation As String, Mem_Lig As String
Dim x As Range
Dim Liste_Lig
'Déclaration des variables "Feuilles"
Set Récurrents = Sheets("Traitement R")
Set Absences = Sheets("Traitement A rép")
'Effacement des filtres existants sur les 2 feuilles
If Récurrents.FilterMode = True Then Récurrents.ShowAllData
If Absences.FilterMode = True Then Absences.ShowAllData
With Récurrents
DerLigneRécurrents = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
.Range("C2:C" & DerLigneRécurrents).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
.Range("C2:C" & DerLigneRécurrents).Value = Range("C2:C" & DerLigneRécurrents).Value
End With
With Absences
DerLigneAbs = .Cells(Rows.Count, 1).End(xlUp).Row
.Activate
.Columns(3).Insert
.Range("C1").Value = "Concaténation"
.Range("C2:C" & DerLigneAbs).FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
.Range("C2:C" & DerLigneAbs).Value = Range("C2:C" & DerLigneAbs).Value
DerLig = DerLigneAbs
For i = 2 To DerLig
If .Cells(i, "B") >= ThisWorkbook.Sheets("Accueil").Range("M1") Then
Concaténation = .Cells(i, "C")
'recherche de la même référence dans la feuille "Traitement R"
Set x = Récurrents.Columns(3).Find(Concaténation)
If Not x Is Nothing Then
Mem_Lig = Mem_Lig & "," & i ' on mémorise les N° de lignes à supprimer
Deb = x.Row
Do
Range(.Cells(DerLigneAbs + 1, "A"), .Cells(DerLigneAbs + 1, "D")).Value = Range(Récurrents.Cells(x.Row, "A"), Récurrents.Cells(x.Row, "D")).Value
.Cells(DerLigneAbs + 1, "F") = .Cells(i, "F") * Récurrents.Cells(x.Row, "E")
.Cells(DerLigneAbs + 1, "E") = .Cells(i, "E")
DerLigneAbs = DerLigneAbs + 1
Set x = Récurrents.Columns(3).FindNext(x)
Loop While Not x Is Nothing And x.Row <> Deb
End If
End If
Next i
End With
'Suppression des lignes inutiles
Liste_Lig = Split(Mem_Lig, ",")
For k = UBound(Liste_Lig) To 2 Step -1
Lig = Liste_Lig(k)
Rows(Lig).Delete
Next
Récurrents.Columns(3).Delete
Absences.Columns(3).Delete
'Libération de la mémoire
Set x = Nothing
Set Récurrents = Nothing
Set Absences = Nothing
End SubPour info, la feuille "Sauvegarde" avait été créée dans le but de conserver les 2 tableaux avant modification, ce qui me permettait de rejouer la séquence autant de fois que je le souhaitais.
Cdlt
Bonjour Arturo,
Désolé de ne pas avoir fait de retour plus tôt, je n'ai pas regardé la macro pendant mon week-end.
En tout cas je te remercie car cela marche parfaitement, j'ai juste fait une petite modification sur la boucle "For" pour la suppression des lignes "inutiles" en mettant 1 à la place du 2 comme tu l'avais fait car sinon la première ligne "inutile" n'était pas supprimée.
For k = UBound(Liste_Lig) To 1 Step -1
Lig = Liste_Lig(k)
Rows(Lig).Delete
NextJe te remercie énormément pour le temps passé sur ce problème.
Bonne journée.
Cordialement,