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

Z

zizou026

XLDnaute Nouveau
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
 
Solution
job75
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...
Trier par date Trier par votes
Z

zizou026

XLDnaute Nouveau
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Classement(3).xlsm
    51.3 KB · Affichages: 14
Vote positif 0 Vote négatif
Solution
Z

zizou026

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
Z

zizou026

XLDnaute Nouveau
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
Cliquez pour agrandir...
 

Pièces jointes

  • Classement4.xlsm
    48.3 KB · Affichages: 3
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonsoir zizou026,
zizou026 à dit:
serait-il possible de copier le titres entre les lignes?
Cliquez pour agrandir...
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.
 

Pièces jointes

  • Classement(4).xlsm
    50.7 KB · Affichages: 8
Dernière édition:
Vote positif 0 Vote négatif
Z

zizou026

XLDnaute Nouveau
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.
Cliquez pour agrandir...
Bonjour job75,

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

Cordialement,

Zizou026
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
Microsoft 365 VBA pour copier et insérer une ligne en dessous
Réponses
5
Affichages
196
Phil69970
Phil69970
halecs93
  • Question
XL 2016 Masquer et afficher lignes
Réponses
3
Affichages
129
gbinforme
G
Y
  • Résolu(e)
XL 2013 Surligner une ligne si curseur sur la ligne et dans une zone définie
Réponses
2
Affichages
173
Yvan1
Y
E
  • Résolu(e)
Microsoft 365 Peut-on insérer un code EntireRow.AutoFit dans une Function?
Réponses
8
Affichages
434
Englobe
E
D
  • Question
Autres boucle copier ligne
Réponses
2
Affichages
322
dadaze
D
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
152
sebastien176
S
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
274
Compte Supprimé 979
C
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
205
aziz
A
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
176
eric72
E
M
  • Question
Microsoft 365 cellules vides et boite de dialogue
Réponses
2
Affichages
182
michel.dupont
M

Membres actuellement en ligne

23 membres et 319 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 480
Messages
2 088 754
Membres
103 944
dernier inscrit
Stbj