Macro pour copier certaines lignes deux fois....

[Christian0258]

Bonjour à tout le forum,

Je souhaiterais votre aide pour l'écriture d'une macro, cette macro devra copier certaines en double puis en modifier une partie de chaque ligne ainsi copiée....
voir fichier

Merci, par avance, pour le temps que vous voudrez bien m'accorder.

Bien amicalement,
Christian

 

[Robert]

Re : Macro pour copier certaines lignes deux fois....

Bonjour Christian, bonjour le forum,

Peut-être comme ça :

Sub Macro1()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim fin As String 'déclare la variable fin
Dim deb As String 'déclare la variable deb (DEBut)
 
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
    'boucle sur toutes les cellule éditées de la colonne F
    For Each cel In .Range("F2:F" & .Cells(Application.Rows.Count, 6).End(xlUp).Row)
        fin = Right(cel.Value, 6) 'définit la varaible fin
        If fin = " + pdt" Then 'condition : si fin = " + pdt"
            deb = Left(cel.Value, Len(cel.Value) - 6) 'définit la variable deb
            dl = Cells(Application.Rows.Count, 1).End(xlUp).Row + 1 'définit la dernière ligne
            cel.EntireRow.Copy Cells(dl, 1) 'copie la ligne de cel en dernier
            Cells(dl, 6).Value = deb 'modifie la valeur de la cellule en colonne F
            cel.EntireRow.Copy Cells(dl + 1, 1) 'recopie la ligne de cel en dernier
            Cells(dl + 1, 6).Value = fin 'modifie la valeur de la cellule en colonne F
        End If 'fin de la condition
    Next cel 'prochaine cellule de la boucle
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

 

[JNP]

Re : Macro pour copier certaines lignes deux fois....

Bonjour le fil 🙂,
Chistian a dit couper, pas copier, Robert 😛...
Personnellement, j'aurais plutôt inséré les lignes au fur et à mesure 🙄...

Sub test()
Dim I As Integer
I = 2
While Range("A" & I - 1) <> ""
If InStr(1, Range("F" & I), "+ pdt") > 1 Then
Range("F" & I) = Replace(Range("F" & I), " + pdt", "")
Rows(I + 1).Insert
Range("A" & I & ":F" & I).Copy Range("A" & I + 1)
Range("F" & I + 1) = "+ pdt"
End If
I = I + 1
Wend
End Sub

Bon WE 😎

 

[Robert]

Re : Macro pour copier certaines lignes deux fois....

Bonjour Christian, JNP, bonjour le forum,

Christian, si tu poses ta question dans le fichier en pièce jointe modifié sans le dire dans le post il va être difficile de pouvoir te répondre. Tu as eu de la chance que JNP a dit n'importe quoi et m'a obligé a réouvrir ton fichier... Ci-dessous la macro modifié pour répondre à ta requête :

Sub Macro1()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim fin As String 'déclare la variable fin
Dim deb As String 'déclare la variable deb (DEBut)
 
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
    'boucle sur toutes les cellule éditées de la colonne F
    For Each cel In .Range("F2:F" & .Cells(Application.Rows.Count, 6).End(xlUp).Row)
        fin = Right(cel.Value, 6) 'définit la varaible fin
        If fin = " + pdt" Then 'condition : si fin = " + pdt"
            cel.Offset(0, -2).Value = "annulé" 'écrit "annulé"dans la colonne D
            deb = Left(cel.Value, Len(cel.Value) - 6) 'définit la variable deb
            dl = Cells(Application.Rows.Count, 1).End(xlUp).Row + 1 'définit la dernière ligne
            cel.EntireRow.Copy Cells(dl, 1) 'copie la ligne de cel en dernier
            Cells(dl, 6).Value = deb 'modifie la valeur de la cellule en colonne F
            cel.EntireRow.Copy Cells(dl + 1, 1) 'recopie la ligne de cel en dernier
            Cells(dl + 1, 6).Value = fin 'modifie la valeur de la cellule en colonne F
        End If 'fin de la condition
    Next cel 'prochaine cellule de la boucle
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

 

[Christian0258]

Re : Macro pour copier certaines lignes deux fois....

Re, le forum, Robert, JNP,

Merci à vous pour vos macros qui fonctionnent parfaitement.
Fort justement, JNP, tu soulèves le point du couper plutôt que copier... ma demande.
Mais je n'est pas pensé au fait que j'ai, dans bon nombres de colonnes sur ces lignes, des données...
Comment modifier ta macro pour qu'elle ne supprime que les cellules des colonnes concernées soit A à G.

Bien à vous,
Christian

 

[Christian0258]

Re : Macro pour copier certaines lignes deux fois....

Re, le forum, Robert,

Tu as raison, je n'ai pas été clair sur ce coup, et je te prie de bien vouloir m'excuser.
Merci pour ta deuxième macro.
Mais en fait, la mention "annulé" je la veux juste sur les plats à décomposer (expl : Chou romanesco sauté + pdt... ect) et non sur les plats décomposés grace à ta macro.

Bien à toi,
Christian

 

[JNP]

Re : Macro pour copier certaines lignes deux fois....

Re 🙂,

Tu as eu de la chance que JNP a dit n'importe quoi et m'a obligé a réouvrir ton fichier...

J'ai l'impression qu'elle en fait un peu trop, maintenant 😛...
Bon, j'ai eu l'impression que ma macro te convenait pas, mais comme je suis aussi tétu que Robert 😛...

Sub test()
Dim I As Integer, J As Byte
I = 2
While Range("A" & I - 1) <> ""
J = InStr(1, Range("F" & I), "+ pdt")
If J > 1 Then
Rows(I + 1).Insert
Rows(I + 1).Insert
Rows(I).Copy Range("A" & I + 1)
Rows(I).Copy Range("A" & I + 2)
Range("D" & I) = "Annulé"
Range("F" & I + 1) = Left(Range("F" & I), J - 1)
Range("F" & I + 2) = Right(Range("F" & I), Len(Range("F" & I)) - J - 1)
I = I + 2
End If
I = I + 1
Wend
End Sub

Permets de réagir à + Riz ou autre... Et de laisser les lignes groupées, ce qui me parait plus logique 🙄...
Bon WE 😎
PS : Je pense à toi, Robert 🙄...

 

[Robert]

Re : Macro pour copier certaines lignes deux fois....

Bonjour le fil, bonjour le forum,

Bon j'avoue qu'à ce stade je ne comprends plus rien... J'envoie juste la macro modifiée en déplaçant dans le code la ligne qui écrit annulé en colonne D.

Sub Macro1()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim fin As String 'déclare la variable fin
Dim deb As String 'déclare la variable deb (DEBut)
 
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
    'boucle sur toutes les cellule éditées de la colonne F
    For Each cel In .Range("F2:F" & .Cells(Application.Rows.Count, 6).End(xlUp).Row)
        fin = Right(cel.Value, 6) 'définit la varaible fin
        If fin = " + pdt" Then 'condition : si fin = " + pdt"
            deb = Left(cel.Value, Len(cel.Value) - 6) 'définit la variable deb
            dl = Cells(Application.Rows.Count, 1).End(xlUp).Row + 1 'définit la dernière ligne
            cel.EntireRow.Copy Cells(dl, 1) 'copie la ligne de cel en dernier
            Cells(dl, 6).Value = deb 'modifie la valeur de la cellule en colonne F
            cel.EntireRow.Copy Cells(dl + 1, 1) 'recopie la ligne de cel en dernier
            Cells(dl + 1, 6).Value = fin 'modifie la valeur de la cellule en colonne F
            cel.Offset(0, -2).Value = "annulé" 'écrit "annulé"dans la colonne D
        End If 'fin de la condition
    Next cel 'prochaine cellule de la boucle
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

 

[Efgé]

Re : Macro pour copier certaines lignes deux fois....

Bonjour Christian0258, Bonjour Robert, Re JNP
Euuhhh... .... on suprime les cellules ou on les remplace ?...
.... on ajoute les lignes en fin de tableau ou on les insère ?...
... on prend en compte la vitesse du vent ?
J'avoue que les modifs de demandes vont plus vite que mes possibilités de codification....
Cordialement

 

[Christian0258]

Re : Macro pour copier certaines lignes deux fois....

Re, le forum, Robert, JNP, Efgé,

Merci à vous pour votre aide, j'ai le choix parmi vos macros...
Merci Robert pour ta 3ème macro, qui me va parfaitement.

Mes excuses pour mon manque de clarté dans ma demande.

Bien à vous,
Christian

 

[Efgé]

Re : Macro pour copier certaines lignes deux fois....

Re
Bon... ..bah... ...je poste quand même le résultat de mes essais.

Sub Christian()
Dim i&, j&, K&, X&
Dim TabReport(), Temp
Application.ScreenUpdating = False
With Sheets("Feuil1")
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        Temp = Split(.Cells(i, 6), "+")
        If UBound(Temp) > 0 Then
            For K = LBound(Temp) To UBound(Temp)
                X = X + 1
                ReDim Preserve TabReport(1 To 7, 1 To X)
                For j = 1 To 7
                    TabReport(j, X) = .Cells(i, j)
                Next j
                TabReport(6, X) = Temp(K)
            Next K
            'Pour supprimer les cellules de A à G
            '.Range(.Cells(i, 1), .Cells(i, 7)).Delete Shift:=xlUp
            'Pour écrire annulé en colonne D
            .Cells(i, 4).Value = "Annulé"
        End If
    Next i
    .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(X, 7) = Application.Transpose(TabReport)
End With
Application.ScreenUpdating = True
End Sub

Cordialement