Vba - inserer et dupliquer 2 lignes puis modifier selon critere

[AlCapone]

Bonjour,
Pour donner suite à cette superbe macro, je souhaiterai savoir, s'il était possible de pousser un peu plus le script en dupliquant une troisième ligne et modifier quelques cellules selon un ou plusieurs critères.

Exemple : dupliquer (en valeur) et insérer 2 fois la ligne 1 si la cellule "C" <> 0 puis modifier la cellule "B" de la 3ème ligne si la cellule "B" de la 2ème ligne est compris entre "X" et "Z".

Je vous ai mis un fichier expliquant plus clairement avec la macro de départ où j'ai essayé de comprendre, en vain, comment ajouter cette écriture et ce que je souhaiterais. Après s'il est plus simple de faire un total des lignes comprenant les critères de sélection, je ne vais quand même pas faire le difficile

Vous remerciant pour votre aide.
Amicalement.
AlCapone

 

[AlCapone]

Re : Vba - inserer et dupliquer 2 lignes

Bonjour,

Après recherche, j'ai demandé un boulot de malade vu que j'ai trouvé comment mettre ce genre de formules (une belle usine à gaz). En revanche, impossible de trouver comment insérer et dupliquer une 3ème ligne en gardant la logique de la macro utilisée, cf fichier joint.

Vous remerciant pour votre aide.

AlCapone

 

[Paf]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Bonjour

Si j'ai bien compris:

La macro Sub Dupli() des classeurs joints insère une ligne si la colonne J est renseignée, et pour cette nouvelle ligne on donne la valeur A à la colonne A et 1 à la colonne I .

Le nouveau besoin:

Si la colonne C est <> 0 ( ? c'est une colonne de dates) 2 lignes sont insérées. C'est clair .
Sur la deuxième ligne insérée il faut modifier la colonne "B" si la colonne "B" de la 1ère ligne est compris entre "X" et "Z". Là c'est pas clair du tout:
- il faut modifier en quoi ? quelle valeur doit on mettre ?
- entre "X" et "Z" : c'est à dire . "Y" ?
- les critères de la première macro ( A en col A et 1 en col I) sont ils conservés ?

Je vous ai mis un fichier expliquant plus clairement

Le fichier n'explique rien du tout :
- aucun exemple de modification de la colonne B dont toutes les cellules comportent la donnée "IMPORT" ( c'est pourtant la seul modif à faire !)
- pour les 3 dernières lignes de la feuille Fichier souhaité les colonnes E et J des 2 dernières lignes ne correspondent pas à la 1ère ?
- les critères de la première macro ( A en col A et 1 en col I) sont conservés

Quelques précisions seraient utiles

A+

 

[AlCapone]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Bonjour

Effectivement les explications claires sont inexistantes.

Ci joint un nouveau fichier :
- 1er onglet : avec la base de travail,
- 2ème onglet : le résultat avec la première macro,
- 3ème onglet : le résultat avec la première macro incluant le résultat souhaité avec la nouvelle macro.

Merci de votre aide et de votre patience.

AlCapone

 

[Paf]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Re ,

Pas encore d'une grande précision !

dans le classeur

SOUHAIT
Dupliquer 2 lignes si la colonne "J" <> 0
Modification de la 1ère ligne dupliquée et insérée (comme la première macro) : mettre "A" à la place de "G" (dans la colonne A) et "0" à la place de "1" (dans la colonne I)
Modification de la 2èmre ligne dupliquée et insérée : il faudrait "juste" mettre "5" à la place du chiffre indiqué en colonne "G".
Mettre en valeur le tout, car à l'origine toutes les cellules de la "base" sont des formules (comme dans la première macro également)

Dans le résultat souhaité:
Modification de la 1ère ligne dupliquée le "0" est remplacé par "1" (dans la colonne I) (soit l'inverse de la demande)
Modification de la 2èmre ligne dupliquée et insérée :en colonne "G" la valeur "4" est insérée ( 5 demandé)


Vous adapterez donc au gré de vos tergiversations la macro :

Sub Dupli2()

 Dim MonTAb, TabCible, TabFinal(), i As Long, j As Long, k As Long, x As Long

 With Worksheets("import CA")

 MonTAb = .Range("A2:O" & .Range("A" & .Rows.Count).End(xlUp).Row)
 For i = LBound(MonTAb) To UBound(MonTAb)
    x = x + 1
    ReDim Preserve TabFinal(1 To UBound(MonTAb, 2), 1 To x)
    For j = LBound(MonTAb, 2) To UBound(MonTAb, 2)
        TabFinal(j, x) = MonTAb(i, j)
    Next j
    
    If MonTAb(i, 10) <> "" Then
        For k = 1 To 2 'boucle de rajout de ligne
            x = x + 1
            ReDim Preserve TabFinal(1 To UBound(MonTAb, 2), 1 To x)
            For j = LBound(MonTAb, 2) To UBound(MonTAb, 2)
                TabFinal(j, x) = MonTAb(i, j)
            Next j
            If k = 1 Then ' première ligne rajoutée
                TabFinal(1, x) = "A"
                TabFinal(9, x) = "1"
            Else           ' deuxièeme ligne rajoutée
                TabFinal(7, x) = 5
            End If
        Next k
    End If
 Next i
  
 .Range("A2:O" & .Range("A" & .Rows.Count).End(xlUp).Row).ClearContents
 .Range("A2").Resize(UBound(TabFinal, 2), UBound(TabFinal, 1)) = Application.Transpose(TabFinal)
 End With
End Sub

Bonne suite

 

[AlCapone]

[RESOLU] Vba - inserer et dupliquer 2 lignes puis modifier selon critere

C'est tout à fait ça, et ce, malgré mon cafouillage

Merci beaucoup

A+

 

[klin89]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Bonsoir à tous, salut paf

Paf, tu te compliques la vie avec tous ces ReDim Preserve
Sinon une variante :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte
    Application.ScreenUpdating = False
    With Sheets("Import CA").Range("A1").CurrentRegion
        a = .Value
    End With
    ReDim b(1 To UBound(a, 1) * 3, 1 To UBound(a, 2))
    b(1, 1) = "TYPE": b(1, 2) = "JAL": b(1, 3) = "DATE": b(1, 4) = "NP"
    b(1, 5) = "N°FACTURE": b(1, 6) = "REFERENCE": b(1, 7) = "CGEN": b(1, 8) = "CTIERS"
    b(1, 9) = "NIVANAL": b(1, 10) = "CODE ANA": b(1, 11) = "LIBELLE": b(1, 12) = "MODERGLT"
    b(1, 13) = "ECHEANCE": b(1, 14) = "DEBIT": b(1, 15) = "CREDIT"
    n = 1
    For i = 2 To UBound(a, 1)
        n = n + 3
        If a(i, 10) <> "" Then
            For j = 1 To UBound(a, 2)
                b(n - 2, j) = a(i, j)
                b(n - 1, j) = a(i, j)
                b(n, j) = a(i, j)
            Next
            b(n - 1, 1) = "A"
            b(n - 1, 9) = 1
            b(n, 7) = 5
        Else
            n = n - 2
            For j = 1 To UBound(a, 2)
                b(n, j) = a(i, j)
            Next
        End If
    Next
    'Restitution en Feuil2
    With Sheets("Feuil2")
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[AlCapone]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Bonjour Klin89,

Merci bien pour ta macro, mais elle bug au niveau de :

With Sheets("Feuil2")

A+

 

[klin89]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Re,

Moi aussi je me complique la vie
Le code un poil réajusté

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte
    Application.ScreenUpdating = False
    With Sheets("Import CA").Range("A1").CurrentRegion
        a = .Value
    End With
    ReDim b(1 To UBound(a, 1) * 3, 1 To UBound(a, 2))
    b(1, 1) = "TYPE": b(1, 2) = "JAL": b(1, 3) = "DATE": b(1, 4) = "NP"
    b(1, 5) = "N°FACTURE": b(1, 6) = "REFERENCE": b(1, 7) = "CGEN": b(1, 8) = "CTIERS"
    b(1, 9) = "NIVANAL": b(1, 10) = "CODE ANA": b(1, 11) = "LIBELLE": b(1, 12) = "MODERGLT"
    b(1, 13) = "ECHEANCE": b(1, 14) = "DEBIT": b(1, 15) = "CREDIT"
    n = 1
    For i = 2 To UBound(a, 1)
        n = n + 3
        For j = 1 To UBound(a, 2)
            b(n - 2, j) = a(i, j)
        Next
        If a(i, 10) <> "" Then
            For j = 1 To UBound(a, 2)
                b(n - 1, j) = a(i, j)
                b(n, j) = a(i, j)
            Next
            b(n - 1, 1) = "A"
            b(n - 1, 9) = 1
            b(n, 7) = 5
        Else
            n = n - 2
        End If
    Next
    'Restitution en Feuil2
    With Sheets(4)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

AlCapone, change le nom de la feuille de destination.
klin89

 

[AlCapone]

Re : Vba - inserer et dupliquer 2 lignes puis modifier selon critere

Ca marche aussi, mais en modifiant le numéro de la feuille, car ça m'a écrasé ce que j'avais déjà en feuille 4.

Merci