[VBA] copier la mise en forme de la ligne du dessus (pour certaines cells)

Le 23/09/2018 à 19:53

Bonjour à tous

On m'a aidé pour réaliser une macro permettant d'insérer une ligne à l'endroit souhaité et en recopiant les formules des cellules de la la ligne du dessus. Cela marche super bien!!

Maintenant, je voudrai que la mise en forme des cellules (cellules ne comportant pas de formules) de la ligne du dessus soient aussi coller dans la ligne insérée. N'étant pas très doué sur VBA, mais curieux et intéressé. J'ai tenté de modifié la macro. Ça fonctionne! Mais....c'est super lent. Je pense que vous allez rigoler en voyant ce que j'ai fait! lol

Du coup, je vous mets ci-dessous la macro (en gras la partie que j'ai ajoutée):

Sub insérer_ligne()

Dim cell As Range, cell1 As Range

Dim i As Integer, j As Integer

With ActiveSheet

' recherche dans tableau de suivi de la dernière cellule correspondant à la catégorie produit sélectionnée

Set cell = .Columns("B").Find(.Range("$B$5"), SearchDirection:=xlPrevious)

If Not cell Is Nothing Then

'recherche dans tableau de suivi de la dernière ligne correspondant à la catégorie produit et type produit sélectionné

Set cell1 = cell

Do

i = cell.Row 'numéro de ligne du tableau

If .Cells(i, "C") = .Range("$C$5") Then Exit Do

Set cell = .Columns("B").FindPrevious(cell)

Loop Until cell.Address = cell1.Address

'ajout nouvelle ligne tableau derrière la dernière trouvée

i = i + 1

.Rows(i).Insert

.Cells(i, "B") = .Range("$B$5")

.Cells(i, "C") = .Range("$C$5")

For j = .Columns("B").Column To .Columns("X").Column

If .Cells(i - 1, j).HasFormula Then .Cells(i - 1, j).Copy .Cells(i, j)

'copier les cellules qui n'ont pas de formules de la ligne du dessus'

If Not .Cells(i - 1, j).HasFormula Then .Cells(i - 1, j).Copy .Cells(i, j)

'supprimer les valeurs du collage pour ne garder que la mise en forme'

If Not .Range(.Cells(i, "D"), .Cells(i, "G")).HasFormula Then .Range(.Cells(i, "D"), .Cells(i, "G")).ClearContents

If Not .Range(.Cells(i, "J"), .Cells(i, "K")).HasFormula Then .Range(.Cells(i, "J"), .Cells(i, "K")).ClearContents

If Not .Range(.Cells(i, "N"), .Cells(i, "O")).HasFormula Then .Range(.Cells(i, "N"), .Cells(i, "O")).ClearContents

If Not .Range(.Cells(i, "R"), .Cells(i, "S")).HasFormula Then .Range(.Cells(i, "R"), .Cells(i, "S")).ClearContents

Next j

End If

End With

End Sub

Au cas où, vous trouverez ci-dessous en pièce jointe, le fichier Excel:

42tableau-de-suivi-des-stocks.xlsm (26.62 Ko)

NB: l'exemple en pièce jointe, est un suivi de stocks. Beaucoup me diront que c'est sans doute inutile de mettre du VBA car d'autres façons plus simples sont possibles. Je le comprends parfaitement. Mais comme je l'ai précisé, "le suivi de stocks" est un exemple pour illustrer de manière simple ma problématique. J'adapterai la problématique à mon VRAI fichier Excel (qui n'est pas un suivi de stocks). De plus, ça me permettra de mieux comprendre si je pratique.

Si quelqu'un pourrait m'aider à améliorer la partie de la macro que j'ai faite. Ça serait super cool! Et je le remercie d'avance.

Cordialement

Monsach

Le 24/09/2018 à 11:21

Bonjour monsach,

En partant du principe d'avoir la syntaxe la plus proche possible de ta procédure, je te propose le code suivant.

Sub insérer_ligne()

    Application.ScreenUpdating = False

    Dim cell As Range, cell1 As Range
    Dim i As Integer

    With ActiveSheet
        ' recherche dans tableau de suivi de la dernière cellule correspondant à la catégorie produit sélectionnée
        Set cell = .Columns("B").Find(.Range("$B$5"), SearchDirection:=xlPrevious)
        If Not cell Is Nothing Then
            'recherche dans tableau de suivi de la dernière ligne correspondant à la catégorie produit et type produit sélectionné
            Set cell1 = cell
            Do
                i = cell.Row   'numéro de ligne du tableau
                If .Cells(i, "C") = .Range("$C$5") Then Exit Do
                Set cell = .Columns("B").FindPrevious(cell)
            Loop Until cell.Address = cell1.Address

            'ajout nouvelle ligne tableau derrière  la dernière trouvée
            i = i + 1
            .Rows(i).Insert
            'copie la ligne du dessus et colle à la destination
            .Range(.Cells(i - 1, 2), .Cells(i - 1, 24)).Copy Destination:=.Cells(i, 2)
            'efface les valeurs des "range"
            .Range(.Cells(i, "D"), .Cells(i, "G")).ClearContents
            .Range(.Cells(i, "J"), .Cells(i, "K")).ClearContents
            .Range(.Cells(i, "N"), .Cells(i, "O")).ClearContents
            .Range(.Cells(i, "R"), .Cells(i, "S")).ClearContents
        End If
    End With

    Application.ScreenUpdating = True

End Sub
Le 26/09/2018 à 19:14
freegide a écrit :

Bonjour monsach,

En partant du principe d'avoir la syntaxe la plus proche possible de ta procédure, je te propose le code suivant.

Sub insérer_ligne()

    Application.ScreenUpdating = False

    Dim cell As Range, cell1 As Range
    Dim i As Integer

    With ActiveSheet
        ' recherche dans tableau de suivi de la dernière cellule correspondant à la catégorie produit sélectionnée
        Set cell = .Columns("B").Find(.Range("$B$5"), SearchDirection:=xlPrevious)
        If Not cell Is Nothing Then
            'recherche dans tableau de suivi de la dernière ligne correspondant à la catégorie produit et type produit sélectionné
            Set cell1 = cell
            Do
                i = cell.Row   'numéro de ligne du tableau
                If .Cells(i, "C") = .Range("$C$5") Then Exit Do
                Set cell = .Columns("B").FindPrevious(cell)
            Loop Until cell.Address = cell1.Address

            'ajout nouvelle ligne tableau derrière  la dernière trouvée
            i = i + 1
            .Rows(i).Insert
            'copie la ligne du dessus et colle à la destination
            .Range(.Cells(i - 1, 2), .Cells(i - 1, 24)).Copy Destination:=.Cells(i, 2)
            'efface les valeurs des "range"
            .Range(.Cells(i, "D"), .Cells(i, "G")).ClearContents
            .Range(.Cells(i, "J"), .Cells(i, "K")).ClearContents
            .Range(.Cells(i, "N"), .Cells(i, "O")).ClearContents
            .Range(.Cells(i, "R"), .Cells(i, "S")).ClearContents
        End If
    End With

    Application.ScreenUpdating = True

End Sub

Bonjour freegide,

Tout d'abord je m'excuse d'avoir pris autant de temps avant de répondre. Je voulais m'assurer que la macro s'adapte à tous mes fichiers Excel. Du coup bonne nouvelle pour moi, ça marche nickel!!!!

Je te remercie, ça m'aide beaucoup!!!

Cordialement

Monsach

Le 26/09/2018 à 21:20

Aucun soucis, je comprends parfaitement.

Je suis ravie de voir que cela semble te convenir.

Pour info, ta macro comportait une incohérence, puisque tu copiais ta ligne systématiquement

If .Cells(i - 1, j).HasFormula Then .Cells(i - 1, j).Copy .Cells(i, j)
'copier les cellules qui n'ont pas de formules de la ligne du dessus'
If Not .Cells(i - 1, j).HasFormula Then .Cells(i - 1, j).Copy .Cells(i, j)

Le tout dans une boucle qui alourdit le traitement.

Pour ton ajout (partie en gras), ton code était mal située. Tu aurais dû le placer après la boucle j.

La procédure pourrait être encore optimisé, mais j'ai délibérément remanié le code pour que tu puisse le comprendre aisément.

Au besoin, si tu as besoin d'éclaircir un point, n'hésite pas.

Rechercher des sujets similaires à "vba copier mise forme ligne dessus certaines"