Etirer des lignes automatiquement (pas simple)

Bonjour,

Salut les amis, j'espère que vous allez bien en ces temps compliqué.

Je m'étais déjà adressé à vous pour des macro afin de pouvoir faire de la saisie automatique et deux personnes m'ont aidé à la faire (il me l'ont faite en entier je ne maitrise pas les Macros). Merci à @Ergotamine et @3GB.

Maintenant un autre problème ce pose, après avoir utiliser leur macros qui marche à la perfection. (la macros me permet de créer automatiquement 2 lignes dans les quelles sont renseignés le montant HT et la TVA), le problème est qu'en créant les lignes les case crées ne sont pas compléter avec le libélé, la date et le N de facture et j'aimerais crées une macro qui me permettent de saisir automatiquement les lignes vides avec l'information de base et cela pour la colonne libellé, et le numéro de facture et la date. Et si possible intégrer dans la macro la saisie automatique du compte 44571000 pour chaque écriture car je le fais à la main (copier coller pour chaque écriture) et sa me prend une demie journée.

PS: je ne peux pas étirer la formule car les les informations changes toute les deux lignes.

Je met en PJ un Excel avec deux onglets, ce que j'ai et ce que j'aimerais avoir c'est beaucoup plus simple a comprendre en regardant l'Excel.

Sur l'Excel j'ai mis une infime partie, en réalité j'ai des milliers de lignes a traité.

Merci par avance.

Bonne journée à vous.

Bonjour,

Je me souviens bien de votre fichier. En supposant toujours que votre table débute à la ligne 2, et qu'on part sur une macro supplémentaire alors :

Sub TRANSFO_2()
Dim LR%, L%
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveSheet
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
    For L = 2 To LR Step 3
        Application.Union(.Cells(L, 1).Resize(3, 2), .Cells(L, 6).Resize(3)).FillDown
        .Cells(L, 3).Offset(2) = "44571000"
    Next L
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Cdlt,

PS : vous n'aviez pas posté votre sujet dans la bonne section du forum

merci bcp !!!

Je dois ajouter sa a la macro précédente ? ou c'est une macro appart entire ?

Bonjour,

Non pour le coup c'est une macro à part entière qui ne traite que le problème présenté. J'ai essayé de tout mettre dans la même, mais il y a des colonnes qui se sont rajoutées ou on été modifiées et je ne m'y retrouve plus. Si vous souhaitez tout dans une même macro il me faudrait le fichier initial initial et ce que vous aimeriez avoir sur quelques lignes.

Cdlt,

Ci joint le fichier avec ce que je veux. SVP bien entendu.

Sub TVA()
Dim I%, L%
Application.ScreenUpdating = False
Application.Calculation = xlManual
With ActiveSheet
L = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
For I = L To 3 Step -1
.Cells(I - 1, 4) = ExtractNum(.Cells(I - 1, 4))
.Rows(I).Resize(2).Insert xlDown
Application.Union(.Cells(I, 4), .Cells(I + 1, 4), .Cells(I - 1, 5)) = 0
.Cells(I, 5).FormulaR1C1 = "=R[-1]C[-1]/1.2"
.Cells(I + 1, 5).FormulaR1C1 = "=R[-2]C[-1]/1.2*0.2"
Next I
.Range("D2:E" & .Cells(.Rows.Count, 4).End(xlUp).Row + 1).NumberFormat = "_-* # ##0.00 €_-;-* # ##0.00 €_-;_-* "" - ""??_-;_-@_-"
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Function ExtractNum(chaine$) As Double
Dim I%
For I = 1 To Len(chaine)
If Not Mid(chaine, I, 1) Like "[0-9,]" Then Mid(chaine, I, 1) = " "
Next I
ExtractNum = CDbl(Replace(chaine, " ", ""))
End Function

La macro que vous m'avez faites de bases.

Bonjour,

Merci pour le fichier. Et voici le code modifié à remplacer et qui devrait faire le travail :

Sub TVA()
Dim I%, L%
Application.ScreenUpdating = False
Application.Calculation = xlManual
With ActiveSheet
    L = .Cells(.Rows.Count, 4).End(xlUp).Row
    For I = L To 2 Step -1
        .Cells(I, 4) = ExtractNum(.Cells(I, 4))
        .Rows(I).Offset(1).Resize(2).Insert xlDown
        Application.Union(.Cells(I, 4).Offset(1), .Cells(I, 4).Offset(2), .Cells(I, 5)) = 0
        .Cells(I, 5).Offset(1).FormulaR1C1 = "=R[-1]C[-1]/1.2"
        .Cells(I, 5).Offset(2).FormulaR1C1 = "=R[-2]C[-1]/1.2*0.2"
        .Cells(I, 3).Offset(2) = "44571000"
        Application.Union(.Cells(I, 1).Resize(3, 2), .Cells(I, 6).Resize(3)).FillDown
    Next I
    .Range("D2:E" & .Cells(.Rows.Count, 4).End(xlUp).Row).Offset(1).NumberFormat = "_-* # ##0.00 €_-;-* # ##0.00 €_-;_-* "" - ""??_-;_-@_-"
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Function ExtractNum(chaine$) As Double
Dim I%
For I = 1 To Len(chaine)
    If Not Mid(chaine, I, 1) Like "[0-9,]" Then Mid(chaine, I, 1) = " "
Next I
ExtractNum = CDbl(Replace(chaine, " ", ""))
End Function

Cdlt,

ouahhhhhhhh vous êtes un génie, cela marche parfaitement.

Merciiiiiiiiiii du fond du coeur.