Insertion ligne avec conditions et copie de données

Bonjour à tous,

Malgré de nombreuses recherches, je n'ai pas réussi à trouver ce que je souhaitais et mes tentatives ont échouées.

Je cherche à :

1/ insérer une ligne entière (en dessous) si la colonne (exemple G) contient un nombre < ou > à 0

2/ ensuite, je souhaite recopier les informations présentes dans la ligne d'origine sur la ligne qui vient d'être insérée (seulement les données de la colonne A à D)

3/ enfin, je souhaite insérer le nombre (qui était différent de 0 dans la ligne d'origine) dans la colonne E ou F selon s'il est positif ou négatif : si négatif en E et si positif en F

et faire ceci jusqu'à la dernière ligne de mon tableau

Merci d'avance pour votre aide,

Roméo

Bonjour,

Fichier en exemple

le code associé:

Sub Insertion()
    Dim Derlig As Long, i As Long
    Application.ScreenUpdating = False
    Derlig = Range("G" & Rows.Count).End(xlUp).Row

    For i = Derlig To 2 Step -1
        If Cells(i, "G") <> 0 Then
            Rows(i + 1).Insert Shift:=xlDown
            Range(Cells(i + 1, "A"), Cells(i + 1, "D")).Value = Range(Cells(i, "A"), Cells(i, "D")).Value
            If Cells(i, "G") > 0 Then Cells(i + 1, "E") = Cells(i, "G") Else: Cells(i + 1, "F") = Cells(i, "G")
        End If
    Next i
End Sub

Cdlt

Bonjour Arturo83,

Merci pour ce retour hyper rapide !

J'ai testé mais cela ne fonctionne pas. Je pense que cela vient de moi car je n'étais pas assez clair dans mon problème.

J'ai fait un fichier Excel avec 2 feuilles :

. Avant : situation avant de lancer la macro

. Après : le résultat que je souhaite obtenir

Quelques précisions :

- Les couleurs ne servent à rien, c'est seulement pour faciliter la lecture

- Il ne peut pas y avoir de signes négatifs dans les colonnes E et F

- L'objectif étant que pour une écriture (à partir de la colonne B "Référence") Total Débit = Total Crédit

Merci d'avance pour votre aide,
Roméo

Bonjour,

Alors voici:

Sub Insertion()
    Dim Derlig As Long, i As Long
    Dim Ecart As Double
    Application.ScreenUpdating = False
    Derlig = Range("A" & Rows.Count).End(xlUp).Row

    For i = Derlig To 2 Step -1
        If Cells(i, "L") <> "" Then
            Ecart = Cells(i, "L")
            Rows(i + 1).Insert Shift:=xlDown
            Range(Cells(i, "A"), Cells(i, "K")).Copy Cells(i + 1, "A")
            Cells(i + 1, "C") = 471
            Cells(i + 1, "D") = "Ecart"
            If Ecart < 0 Then
                Cells(i + 1, "E") = Abs(Ecart)
                Cells(i + 1, "F") = ""
            Else
                Cells(i + 1, "F") = Abs(Ecart)
            End If
        End If
    Next i
End Sub

Cdlt

C'est super Arturo83 (merci !) à un détail près : cela insère une ligne même quand cela n'est pas nécessaire.

Dans mon exemple, la première écriture (celle avec la référence "A") est déjà équilibré (600 = 500 + 100).

Cela insère donc une ligne nulle ce qui est problématique dans mon cas.

Une idée ?

Merci

Ok, je vous corrigerai ça demain.

Bonjour,

Comme promis, voici la petite modif

Sub Insertion()
    Dim Derlig As Long, i As Long
    Dim Ecart As Double
    Application.ScreenUpdating = False
    Derlig = Range("A" & Rows.Count).End(xlUp).Row

    For i = Derlig To 2 Step -1
        If Cells(i, "L") <> "" And Cells(i, "L") <> 0 Then
            Ecart = Cells(i, "L")
            Rows(i + 1).Insert Shift:=xlDown
            Range(Cells(i, "A"), Cells(i, "K")).Copy Cells(i + 1, "A")
            Cells(i + 1, "C") = 471
            Cells(i + 1, "D") = "Ecart"
            If Ecart < 0 Then
                Cells(i + 1, "E") = Abs(Ecart)
                Cells(i + 1, "F") = ""
            Else
                Cells(i + 1, "F") = Abs(Ecart)
            End If
        End If
    Next i
End Sub

Cdlt

Excellent !

Bravo pour la rapidité et la qualité de la réponse.

Merci