Ajout de ligne automatique

Bonjour à tous,

Je n'ai pas réussi à trouver la solution à mon problème, donc je me permets de créer ce post.

J'ai un fichier sur lequel je souhaiterai copier une ligne sur deux, l'insérer, modifier une donnée, et inverser un montant. Je vais essayer de montrer un exemple, ça sera plus parlant :

Tableau initial :

Etc etc sur un peu plus de 800 lignes

L'objectif final serait que je puisse transformer le tableau de cette manière :

A savoir que dans la colonne Compte, la valeur de contrepartie à mon compte 512000 (compte comptable de la banque) sera toujours un compte 471000 (que l'on appelle compte d'attente en cabinet comptable).

Si quelqu'un à une idée pour ne pas avoir à passer sur les 800 lignes, c'est avec plaisir

Bonjour,

A tester :

Option Explicit

Sub Contrepartie()

Dim I As Integer, DerniereLigne As Integer, PremiereLigne As Integer
Dim AireATrier As Range, AireIndex As Range, AireCompte As Range

  With ActiveSheet

       DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
       PremiereLigne = DerniereLigne + 1
       For I = 2 To DerniereLigne
           .Cells(I, 5) = I
       Next I
       .Range(.Cells(2, 1), .Cells(DerniereLigne, 5)).Copy Destination:=.Cells(PremiereLigne, 1)

       DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
       For I = PremiereLigne To DerniereLigne
           .Cells(I, 3) = -.Cells(I, 3)
           .Cells(I, 4) = "471000"
       Next I

       Set AireATrier = .Range(.Cells(1, 1), .Cells(DerniereLigne, 5))
       Set AireIndex = .Range(.Cells(1, 5), .Cells(DerniereLigne, 5))
       Set AireCompte = .Range(.Cells(1, 4), .Cells(DerniereLigne, 4))

       .Sort.SortFields.Clear
       .Sort.SortFields.Add2 Key:=AireIndex, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=AireCompte, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With .Sort
            .SetRange AireATrier
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Columns(5).ClearContents

       Set AireATrier = Nothing: Set AireIndex = Nothing: Set AireCompte = Nothing

  End With

End Sub

bonjour,

Vous avez un example (min. 10 lignes) de cela ? C'est un simple range ou un tableau ?

Bonjour,
Un exemple simple réalisé avec Power Query.
Cdlt.

Bonjours,

Par power query aussi

Bonjour,

Bon j'arrive en retard mais je soumets ma proposition quand même

Power Query aussi .....

bonjour,

Autre solutio, VBA :

Sub galopin()
Dim i&, Arr, k, iC
Arr = [A1].CurrentRegion.Value2
k = 2 * UBound(Arr) - 1
ReDim ArrC(1 To 2 * UBound(Arr) - 1, 1 To 4)
For i = UBound(Arr) To 2 Step -1
    ArrC(k, 1) = Arr(i, 1)
    ArrC(k, 2) = Arr(i, 2)
    ArrC(k, 3) = -Arr(i, 3)
    ArrC(k, 4) = 471000
    k = k - 1
    For iC = 1 To 4
        ArrC(k, iC) = Arr(i, iC)
    Next
    k = k - 1
Next
    For iC = 1 To 4
        ArrC(1, iC) = Arr(1, iC)
    Next
[F1].Resize(UBound(ArrC), UBound(ArrC, 2)) = ArrC
End Sub

A+

Bonjour à tous,

Une variante par macro...à tester.....

Sub test()
 Dim tb, Newtb(), i&, k&
 Dim compte
  compte = InputBox("Numéro ?", "Compte")
   If compte <> "" Then
     With Sheets("Feuil1")
      tb = .Range("A1").CurrentRegion
      k = 0
      ReDim Newtb(0 To UBound(tb, 1) * 2, 1 To 4)
       For i = 2 To UBound(tb, 1)
        If tb(i, 1) <> "" Then
          Newtb(k, 1) = tb(i, 1)
          Newtb(k + 1, 1) = tb(i, 1)
          Newtb(k, 2) = tb(i, 2)
          Newtb(k + 1, 2) = tb(i, 2)
          Newtb(k, 3) = tb(i, 3)
          Newtb(k + 1, 3) = Val(tb(i, 3)) * -1
          Newtb(k, 4) = tb(i, 4)
          Newtb(k + 1, 4) = compte
          k = k + 2
        End If
       Next i

       If k > 0 Then
        On Error Resume Next
        .Cells.Borders.LineStyle = xlLineStyleNone
        .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
        .Range("A2").Resize(k, 4).Value = Newtb
        .Range("A1").CurrentRegion.Borders.Weight = xlThin
       End If
     End With
    End If
   Erase tb: Erase Newtb
End Sub

Cordialement,

Bonjour tout le monde,

Je vous remercie pour vos retours nombreux, je ne peux pas cocher une seule solution car il y en a plusieurs qui fonctionnent mais merci beaucoup en tout cas !