XL 2016 Macro insérer ligne et copier informations

[Arwen43]

Bonjour

Je voudrais faire la macro suivante:
* insérer une ligne en dessous dès que la cellule de la colonne B est égale à "GARMH"
* copier les informations de la cellule colonne A ligne précédente et colonne B ligne précédente dans cette nouvelle ligne créée

Je ne sais pas si cela est trés clair.

Merci de votre aide.

 

[HopHopHop]

Salut Arwen43

Je ne suis pas un crac en VBA mais ce code devrait t'aider.

Si tu me passe un fichier sur lequel je peux travailler, je suis sure de pouvoir trouver une autre solution.


A plus

HopHopHop

Sub creation_ligne ()

Dim ligne as integer

Set Data = Sheets("nom_de_feuille").Range("AA:CC")

While Data.Cells(ligne, 1) <> ""
    If Data.Cells(ligne, 2) = "GARMH" Then
    Data.Cells(ligne + 1, 1).Select
    Selection.EntireRow.Insert
    Data.Cells(ligne-1, 1).Copy
    Data.Cells(ligne, 1).Select
    Selection.Paste
    Data.Cells(ligne+1, 2).Copy
    Data.Cells(ligne, 2).Select
    Selection.Paste
    End If
ligne = ligne + 1
Wend
End Sub

 

[Arwen43]

Sub creation_ligne () Dim ligne as integer Set Data = Sheets("nom_de_feuille").Range("AA:??") While Data.Cells(ligne, 1) <> "" If Data.Cells(ligne, 2) = "GARMH" Then Data.Cells(ligne + 1, 1).Select Selection.EntireRow.Insert Data.Cells(ligne-1, 1).Copy Data.Cells(ligne, 1).Select Selection.Paste Data.Cells(ligne+1, 2).Copy Data.Cells(ligne, 2).Select Selection.Paste End If ligne = ligne + 1 Wend End Sub

Merci de l'info. En pièce jointe le fichier, merci me dire si vous pouvez m'aider pour ma macro.

 

[HopHopHop]

Est-ce qu'il faut supprimer des lignes aussi ?

 

[Arwen43]

Est-ce qu'il faut supprimer des lignes aussi ?

non pas de suppression de ligne, simplement en rajouter une et reporter les informations colonne A et B de la ligne précédente.

Merci de votre aide

 

[HopHopHop]

Ça fait le boulot que tu veux mais comme je n'ai pas le contexte de ce tableau, je ne suis pas certain que cela va suffire.

Sub creation_ligne()

Dim ligne As Integer

Set Data = Range("A:F")
ligne = 1
Application.DisplayAlerts = False
'Application.EnableEvents = False
While Data.Cells(ligne, 2) <> ""
Data.Cells(ligne, 1).Select
If Data.Cells(ligne, 2) = "GARMH" Then
Data.Cells(ligne + 1, 1).Select
Selection.EntireRow.Insert
Data.Cells(ligne, 1).Copy
Data.Cells(ligne + 1, 1).Select
ActiveSheet.Paste
Data.Cells(ligne, 2).Copy
Data.Cells(ligne + 1, 2).Select
ActiveSheet.Paste
ligne = ligne + 1
End If
ligne = ligne + 1
Wend
'Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

 

[Arwen43]

Ça fait le boulot que tu veux mais comme je n'ai pas le contexte de ce tableau, je ne suis pas certain que cela va suffire.

Sub creation_ligne()

Dim ligne As Integer

Set Data = Range("A:F")
ligne = 1
Application.DisplayAlerts = False
'Application.EnableEvents = False
While Data.Cells(ligne, 2) <> ""
Data.Cells(ligne, 1).Select
If Data.Cells(ligne, 2) = "GARMH" Then
Data.Cells(ligne + 1, 1).Select
Selection.EntireRow.Insert
Data.Cells(ligne, 1).Copy
Data.Cells(ligne + 1, 1).Select
ActiveSheet.Paste
Data.Cells(ligne, 2).Copy
Data.Cells(ligne + 1, 2).Select
ActiveSheet.Paste
ligne = ligne + 1
End If
ligne = ligne + 1
Wend
'Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Merci ça fonctionne trés trés bien.
Copier coller les formules des colonnes C, D , E et F sur la nouvelle ligne
Je pense que c'est assez facile.

Et aussi (plus compliqué à mon sens)
Sur la première ligne (celle qui est copiée) Remplacer "GARMH" par "GAR"
Sur la deuxième ligne (celle qui a été insérée) Remplacer "GARMH" par "MH"

Merci beaucoup, cela est une grande aide pour moi

 

[Arwen43]

J'ai oublié une phrase
"Peut-on l'améliorer avec les fonctions suivantes":

Copier coller les formules........


Merci

 

[HopHopHop]

Je crois que j'ai trouvé quelques chose pour ça aussi.
Je test sur ton fichier

 

[Arwen43]

J'ai réussi à faire la première amélioration.

Reste plus que la deuxième avec la partie remplacer "GARMH"

Une idée svp? Merci beaucoup de votre implication

 

[Arwen43]

Je crois que j'ai trouvé quelques chose pour ça aussi.
Je test sur ton fichier

Merci beaucoup

 

[HopHopHop]

Voilà !!
Ca marche mais c'est très long sur mon ordi.

J'espère que sur le votre ça va aller mieux.

Sub creation_ligne()
Dim ligne As Integer
Set Data = Range("A:F")
ligne = 1
Application.DisplayAlerts = False
While Data.Cells(ligne, 2) <> ""
Data.Cells(ligne, 1).Select
If Data.Cells(ligne, 2) = "GARMH" Then
Data.Cells(ligne + 1, 1).Select
Selection.EntireRow.Insert
Range(Data.Cells(ligne, 1), Data.Cells(ligne, 6)).Copy
Data.Cells(ligne + 1, 1).Select
ActiveSheet.Paste
Data.Cells(ligne + 1, 2).FormulaR1C1 = "MH"
Data.Cells(ligne, 2).FormulaR1C1 = "GAR"
ligne = ligne + 1
End If
ligne = ligne + 1
Wend
Application.DisplayAlerts = True
End Sub

 

[Arwen43]

Sub creation_ligne() Dim ligne As Integer Set Data = Range("A:F") ligne = 1 Application.DisplayAlerts = False While Data.Cells(ligne, 2) <> "" Data.Cells(ligne, 1).Select If Data.Cells(ligne, 2) = "GARMH" Then Data.Cells(ligne + 1, 1).Select Selection.EntireRow.Insert Range(Data.Cells(ligne, 1), Data.Cells(ligne, 6)).Copy Data.Cells(ligne + 1, 1).Select ActiveSheet.Paste Data.Cells(ligne + 1, 2).FormulaR1C1 = "MH" Data.Cells(ligne, 2).FormulaR1C1 = "GAR" ligne = ligne + 1 End If ligne = ligne + 1 Wend Application.DisplayAlerts = True End Sub

Ca fonctionne trés bien, merci beaucoup!

 

[HopHopHop]

Mais de rien !

Je suis en train d'apprendre le VBA pour le boulot et je manque d'exercice.

Je vous aide pour m'aider !

a toute