XL 2010 Insérer une une ligne et copier la cellule d'en dessous

zizou026 · 2 Janvier 2021

Bonjour,
Une excellente année à toutes et à tous.
J'ai trouvé ce formule :
Sub complèter()
Sheets("toto").Select
x = [B65536].End(3).Row
For Each C In Range("A1:A" & x).SpecialCells(xlCellTypeBlanks)
C.Value = Range(C.Address).End(3).Value
Next
End Sub
Comment faire pour ça insère une ligne et copie la cellule d'en dessous?
Par avance, je vous remercie.
Cordialement,
zizou

job75 · 4 Janvier 2021

Bonjour zizou026, le forum,

Dans ce fichier (3) j'ai supprimé la RAZ et ajouté des tests pour le traitement du tableau, c'est plus rapide :

Code:

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, test As Boolean, j%
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.FormatConditions.Delete 'supprime toutes les MFC
    '---tableau des résultats---
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 3 Then ncol = 3
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To Rows.Count, 1 To ncol)
        For i = 2 To UBound(tablo)
            If tablo(i, 1) <> "" And tablo(i - 1, 1) <> "" Then 'les 2 lignes sont...

zizou026 · 4 Janvier 2021

job75 à dit:
Il n'y a pas à se préoccuper du nom de la feuille.

Comme déjà dit c'est la feuille active qui est traitée quand on appuie sur les touches Ctrl+M.

Bonjour job75,

Je te remercie beaucoup, ça fonctionne très bien. Comme il y a plus d'une vingtaine d'onglets c'est pour cette raison que je te posais la question. Encore un immense merci et je te souhaite une excellente journée.
Cordialement,
Zizou026

job75 · 4 Janvier 2021

Bonjour zizou026, le forum,

Dans ce fichier (3) j'ai supprimé la RAZ et ajouté des tests pour le traitement du tableau, c'est plus rapide :

Code:

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, test As Boolean, j%
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.FormatConditions.Delete 'supprime toutes les MFC
    '---tableau des résultats---
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 3 Then ncol = 3
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To Rows.Count, 1 To ncol)
        For i = 2 To UBound(tablo)
            If tablo(i, 1) <> "" And tablo(i - 1, 1) <> "" Then 'les 2 lignes sont ignorées
                n = n + 1
                If i > 2 Then test = tablo(i - 2, 1) = ""
                If tablo(i, 2) <> tablo(i - 1, 2) Or test Then
                    resu(n + 1, 1) = tablo(i, 1)
                    resu(n + 1, 2) = tablo(i, 3)
                    n = n + 2
                End If
                For j = 1 To ncol
                    resu(n, j) = tablo(i, j)
                Next j
            End If
        Next i
        If n Then .Offset(1).Resize(n) = resu 'restitution
        .Rows(2).Offset(n).Resize(Rows.Count - n - .Row).EntireRow.Delete 'RAZ en dessous
    End With
    '---mise en forme conditionnelle (MFC)---
    With .UsedRange.Offset(1)
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
        .FormatConditions(1).Font.Bold = True 'gras
        .FormatConditions(1).Interior.ColorIndex = 48 'gris foncé
    End With
End With
End Sub

Pour tester j'ai recopié le tableau A2:S199 sur 500 148 lignes, la macro s'exécute en 12 secondes chez moi.

A+

zizou026 · 4 Janvier 2021

Bonjour job75,
Franchement, c'est super génial... sur le tableau d'exemple je n'ai pas du tout d'erreur.
Par contre sur le tableau réel, il y a des loupés, (c'est très gentille à toi) je vais les corriger manuellement.
Pour info : j'ai ajouté un bouton sur chaque feuille.
Ce n'est pas pour te flatter, mais, tu as de suite compris ce que voulais et trouver une solution Lol.
Mille merci job75 et je te souhaite une excellente journée. stay safe!!!
Cordialement,
zizou026

zizou026 · 10 Janvier 2021

job75 à dit:

Dans ce fichier (2) j'ai modifié le critère pour la RAZ, c'est mieux je pense :

VB:

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, j%
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
'---RAZ pour le cas où la macro a déjà été exécutée---
ActiveSheet.Cells.FormatConditions.Delete 'supprime les MFC
With ActiveSheet.UsedRange
    .Columns(1).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(0).Offset(1) = "=1/OR(RC[1]="""",R[-1]C[1]="""")"
    .Columns(0).Offset(1) = .Columns(0).Offset(1).Value 'supprime les formules
    .EntireRow.Sort .Columns(0), xlDescending, Header:=xlYes 'tri pour regrouper et accélérer
    .Columns(0).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'supprime les lignes
    .Columns(0).EntireColumn.Delete
End With
'---traitement---
With ActiveSheet.UsedRange
    ncol = .Columns.Count
    If ncol < 3 Then ncol = 3
    tablo = .Resize(, ncol) 'matrice, plus rapide
    ReDim resu(1 To Rows.Count, 1 To ncol)
    For i = 2 To UBound(tablo)
        If tablo(i, 2) = tablo(i - 1, 2) Then
            n = n + 1
        Else
            n = n + 3
            resu(n - 1, 1) = tablo(i, 1)
            resu(n - 1, 2) = tablo(i, 3)
        End If
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    .Offset(1).Resize(n) = resu 'restitution
End With
'---mise en forme conditionnelle (MFC)---
With ActiveSheet.UsedRange.Offset(1)
    .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
    .FormatConditions(1).Font.Bold = True 'gras
    .FormatConditions(1).Interior.ColorIndex = 48 'gris foncé
End With
End Sub

zizou026 · 10 Janvier 2021

Bonsoir job75,
Sans abuser de ta gentillesse, serait-il possible de copier le titres entre les lignes?
Merci beaucoup et te souhaite une excellente soirée.
Cordialement,
Zizou026

job75 · 11 Janvier 2021

Bonsoir zizou026,

zizou026 à dit:
serait-il possible de copier le titres entre les lignes?

Voyez ce fichier (4) et la nouvelle macro :

VB:

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, test As Boolean, j%
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.FormatConditions.Delete 'supprime toutes les MFC
    '---tableau des résultats---
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 3 Then ncol = 3
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To Rows.Count, 1 To ncol)
        For i = 2 To UBound(tablo)
            If tablo(i, 1) <> "" And tablo(i, 1) <> tablo(1, 1) And (tablo(i - 1, 1) <> tablo(1, 1) Or i = 2) Then 'les 3 lignes sont ignorées
                n = n + 1
                If i > 3 Then test = tablo(i - 3, 1) = ""
                If tablo(i, 2) <> tablo(i - 1, 2) Or test Then
                    For j = 1 To ncol
                        resu(n + 1, j) = tablo(1, j) 'copie les en-têtes
                    Next j
                    resu(n + 2, 1) = tablo(i, 1)
                    resu(n + 2, 2) = tablo(i, 3)
                    n = n + 3
                End If
                For j = 1 To ncol
                    resu(n, j) = tablo(i, j)
                Next j
            End If
        Next i
        If n Then .Offset(1).Resize(n) = resu 'restitution
        .Rows(2).Offset(n).Resize(Rows.Count - n - .Row).EntireRow.Delete 'RAZ en dessous
    End With
    '---mises en forme conditionnelles (MFC)---
    With .UsedRange.Offset(1)
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
        .FormatConditions(1).Font.Bold = True 'gras
        .FormatConditions(1).Interior.ColorIndex = 15 'gris
    End With
    With .UsedRange.Offset(2)
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(-1, 1).Address(0, 1) & "="""""
        .FormatConditions(2).Font.Bold = True 'gras
        .FormatConditions(2).Interior.ColorIndex = 48 'gris foncé
    End With
End With
End Sub

Edit : après exécution on peut masquer les 2 premières lignes ou ajouter avant le dernier End With :

VB:

.Rows("1:2").Hidden = True

Bonne nuit.

zizou026 · 11 Janvier 2021

job75 à dit:

Bonsoir zizou026,

Voyez ce fichier (4) et la nouvelle macro :

VB:

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, test As Boolean, j%
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.FormatConditions.Delete 'supprime toutes les MFC
    '---tableau des résultats---
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 3 Then ncol = 3
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To Rows.Count, 1 To ncol)
        For i = 2 To UBound(tablo)
            If tablo(i, 1) <> "" And tablo(i, 1) <> tablo(1, 1) And (tablo(i - 1, 1) <> tablo(1, 1) Or i = 2) Then 'les 3 lignes sont ignorées
                n = n + 1
                If i > 3 Then test = tablo(i - 3, 1) = ""
                If tablo(i, 2) <> tablo(i - 1, 2) Or test Then
                    For j = 1 To ncol
                        resu(n + 1, j) = tablo(1, j) 'copie les en-têtes
                    Next j
                    resu(n + 2, 1) = tablo(i, 1)
                    resu(n + 2, 2) = tablo(i, 3)
                    n = n + 3
                End If
                For j = 1 To ncol
                    resu(n, j) = tablo(i, j)
                Next j
            End If
        Next i
        If n Then .Offset(1).Resize(n) = resu 'restitution
        .Rows(2).Offset(n).Resize(Rows.Count - n - .Row).EntireRow.Delete 'RAZ en dessous
    End With
    '---mises en forme conditionnelles (MFC)---
    With .UsedRange.Offset(1)
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
        .FormatConditions(1).Font.Bold = True 'gras
        .FormatConditions(1).Interior.ColorIndex = 15 'gris
    End With
    With .UsedRange.Offset(2)
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(-1, 1).Address(0, 1) & "="""""
        .FormatConditions(2).Font.Bold = True 'gras
        .FormatConditions(2).Interior.ColorIndex = 48 'gris foncé
    End With
End With
End Sub

Edit : après exécution on peut masquer les 2 premières lignes ou ajouter avant le dernier End With :

VB:

.Rows("1:2").Hidden = True

Bonne nuit.

Bonjour job75,

Merci Beaucoup, je te souhaite une excellente journée.

Cordialement,

Zizou026

XL 2010 Insérer une une ligne et copier la cellule d'en dessous

zizou026

XLDnaute Nouveau

job75

zizou026

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

zizou026

XLDnaute Nouveau

zizou026

XLDnaute Nouveau

Pièces jointes

zizou026

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

zizou026

XLDnaute Nouveau

Discussions similaires