Boucle macro en insérant lignes

P

PierreGeo

XLDnaute Nouveau
Bonjour,

Je n'arrive pas à créer une boucle macro pour effectuer les opérations suivantes sur cette base de donnée:

- insérer 3 lignes au dessus de chaque lot de données régionales/nationales afin d'ajouter les années 2000, 2001 et 2002 (les données pour ces années resteront vides)

(sur le même modèle que BE / Belgique effectué manuellement)

Merci par avance pour votre aide.

--------------

La macro que j'ai créée:

Sub ABCDEF()
'
' ABCDEF Macro
'
' Keyboard Shortcut: Ctrl+n
'
Rows("16:18").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A19:A21").Select
Selection.AutoFill Destination:=Range("A16:A21"), Type:=xlFillDefault
Range("A16:A21").Select
Range("B19:B21").Select
Range("B21").Activate
Selection.AutoFill Destination:=Range("B16:B21"), Type:=xlFillDefault
Range("B16:B21").Select
Range("C19:C21").Select
Selection.AutoFill Destination:=Range("C16:C21"), Type:=xlFillDefault
Range("C16:C21").Select
Range("A33").Select
End Sub
 

Pièces jointes

  • ilc_li41.xls
    268.5 KB · Affichages: 42
Trier par date Trier par votes
B

Bebere

XLDnaute Barbatruc
Re : Boucle macro en insérant lignes

bonjour PierreGeo
il faut commencer par la fin pour ajouter ou supprimer des lignes
Code: 
Sub ABCDEF()
    Dim tbl, a, dico As Dictionary, i As Long, L As Long
    
    Application.ScreenUpdating = False
    
    With Sheet1
        tbl = .UsedRange

        Set dico = New Dictionary
        'microsoft scripting runtime doit être coché dans menu outils,choix références
        '  ou cette ligne si problème et déclarer dico as Object à la place de as dictionary(ligne dim)
        'Set mondico = CreateObject("scripting.dictionary")
        For i = 2 To UBound(tbl, 1)
            dico(tbl(i, 1)) = tbl(i, 1)
        Next i

        a = dico.items
        L = .Range("A65536").End(xlUp).Row

        For i = UBound(a) To 0 Step -1
            If i > 0 Then
                nbl = Application.CountIf(.Range("A:A"), "=" & a(i))
                L = L - nbl
                b = .Cells(L + 1, 2)
                For c = 1 To 3
                    .Rows(L + c).Insert
                Next c
                .Cells(L + 1, 1) = a(i): .Cells(L + 1, 2) = b: .Cells(L + 1, 3) = 2000
                .Cells(L + 2, 1) = a(i): .Cells(L + 2, 2) = b: .Cells(L + 2, 3) = 2001
                .Cells(L + 3, 1) = a(i): .Cells(L + 3, 2) = b: .Cells(L + 3, 3) = 2002
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
    
End Sub
 
Vote positif 0 Vote négatif
Modeste

Modeste

XLDnaute Barbatruc
Re : Boucle macro en insérant lignes

Bonjour PierreGeo,

Tu peux essayer le code suivant (si j'ai bien compris):
VB: 
Sub insérer()
Application.ScreenUpdating = False
With Sheets("Sheet1")
For lig = .Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
    If .Cells(lig, 3) = 2003 Then
        .Rows(lig).Copy
        .Rows(lig).Resize(3, 1).Insert
        .Cells(lig, 3).Resize(3, 1) = Application.Transpose(Array(2000, 2001, 2002))
        .Cells(lig, 4).Resize(3, 1) = ""
    End If
Next lig
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

... Attention: le temps d'exécution risque de "s'étirer" sensiblement :eek:

[Edit:] Salut Bebere :)
[Edit bis:] Le code de Bebere sera bien plus rapide!
 
Dernière édition:
Vote positif 0 Vote négatif
P

PierreGeo

XLDnaute Nouveau
Re : Boucle macro en insérant lignes

Merci beaucoup pour votre aide! :)

Le code de Modeste a marché (avec un petit temps d'attente, 5 secondes environ, donc très raisonnable!)
J'ai pu l'adapter à une autre base de données un petit peu différente donc c'est très satisfaisant de voir que je commence à comprendre le code!


En revanche, je n'ai pas réussi à faire marcher le code de Bebere (probablement car je n'ai pas bien saisi les instructions concernant "microsoft scripting runtime").
Le message d'erreur est le suivant : "Compile error: User-defined type not defined"

Merci encore pour votre aide
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Boucle macro en insérant lignes

Bonsoir à tous

PierreGeo
Il suffit de modifier comme ceci ces deux lignes et cela fonctionnera
Dim tbl, a, dico As object, i As Long, L As Long

Set dico = CreateObject("scripting.dictionary")

La macro devra au final avoir cette tête là
(cliques sur l'image pour la voir en taille réelle)
01codeBebere.png
 
Dernière édition:
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : Boucle macro en insérant lignes

Bonsoir à tous,

Bof :rolleyes:
VB: 
Sub essai()
Dim i As Long, x as long
    Application.ScreenUpdating = False
    For i = Range("C" & Rows.Count).End(xlUp).Row To 3 Step -1
        If Cells(i - 1, "C") > Cells(i, "C") Then
            x = Cells(i, "C") - 2000
            Rows(i).Resize(x).Insert
            With Cells(i, "C")
                .Value = 2000
                .AutoFill .Resize(x), 2
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
klin89
 
Dernière édition:
Vote positif 0 Vote négatif
P

PierreGeo

XLDnaute Nouveau
Re : Boucle macro en insérant lignes

Staple1600 , ça marche parfaitement maintenant. Merci !

klin89, merci pour cet "essai" comme le nom de ta macro l'indique. Ca marche aussi très bien mais ça aurait été parfait avec les codes et noms des régions/pays également recopiés pour les nouvelles années insérées. Aurais-tu la possibilité de modifier le code pour que cela soit le cas? Merci par avance :)
 
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : Boucle macro en insérant lignes

Re PierreGeo ,

VB: 
Sub essai()
Dim i As Long, x As Long
    Application.ScreenUpdating = False
    For i = Range("C" & Rows.Count).End(xlUp).Row To 3 Step -1
        If Cells(i - 1, "C") > Cells(i, "C") Then
            x = Cells(i, "C") - 2000
            Rows(i).Resize(x).Insert
            With Cells(i, "C")
                .Value = 2000
                .AutoFill .Resize(x), 2
                With .Offset(, -2).Resize(x, 2)
                    .Value = Cells(i - 1, "A").End(xlDown).Resize(, 2).Value
                End With
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
klin89
 
Vote positif 0 Vote négatif
P

PierreGeo

XLDnaute Nouveau
Re : Boucle macro en insérant lignes

Oh, je viens de me rendre compte qu'il faut aussi que j'ajoute les années 2014 et 2015 sur cette même base de donnée.
Est-ce possible de le faire en reprenant ce même code?
J'ai essayé mais sans succès... ça reste très complexe pour moi.
Merci par avance!
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Boucle macro en insérant lignes

Bonsoir et bonne nuit


A l'ancienne et à la bonne franquette :)
Mais fait le job malgré tout ;)
Lancer la macro Traitement
Code: 
Sub Traitement()
Application.ScreenUpdating = False
mDEBUT
mMILIEU
mFIN
Application.ScreenUpdating = True
End Sub
Private Sub mDEBUT()
Dim i&
For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
If Cells(i, 3) = "2003" Then
Rows(i).Resize(5).Insert Shift:=xlDown
End If
Next
End Sub
Private Sub mMILIEU()
Dim dl&
dl = Cells(Rows.Count, 1).End(3).Row + 5
With Range(Cells(7, 1), Cells(dl, 2))
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Private Sub mFIN()
Range("D7:D9").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C7:C8") = Application.Transpose(Array(2000, 2001))
Range("C7:C8").AutoFill Destination:=Range("C7:C22"), Type:=xlFillDefault
Range("C7:C22").AutoFill Destination:=Range("C7:C4822"), Type:=xlFillCopy
Rows("2:6").Delete
Range("A4812:B4817").FillDown
End Sub
 
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : Boucle macro en insérant lignes

Bonsoir le forum :)

Une variante plus souple, via une InputBox et sans passer par l'insertion de lignes.
Le résultat s'affiche à côté du tableau original.
1ère version :
VB: 
Sub Version1()
Dim a, b(), i As Long, txt As String
Dim e, n As Long, Fin As Long
    Fin = Application.InputBox("Choisir l'année", , 2015, Type:=1)
    Fin = Fin - 1999
    Application.ScreenUpdating = False
    With Sheets("Sheet1").Range("A1").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                .Item(a(i, 1)) = a(i, 2)
            Next
            ReDim b(1 To .Count * Fin, 1 To UBound(a, 2))
            For Each e In .keys
                For i = 1 To Fin
                    n = n + 1
                    .Item(e & i + 1999) = n
                    b(n, 1) = e: b(n, 2) = .Item(e): b(n, 3) = i + 1999
                Next
            Next
            For i = 2 To UBound(a, 1)
                txt = a(i, 1) & a(i, 3)
                If .exists(txt) Then
                    b(.Item(txt), 2) = a(i, 2)
                    b(.Item(txt), 4) = a(i, 4)
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .Font.Bold = True
                    .Interior.ColorIndex = 40
                    .BorderAround Weight:=xlThin
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub
2ème version :
Pour le fun, j'ai rajouté une colonne pour pointer les lignes existantes.
VB: 
Sub Version2()
Dim a, b(), i As Long, txt As String
Dim e, n As Long, Fin As Long
    Fin = Application.InputBox("Choisir l'année.", , 2015, Type:=1)
    Fin = Fin - 1999
    Application.ScreenUpdating = False
    With Sheets("Sheet1").Range("A1").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                .Item(a(i, 1)) = a(i, 2)
            Next
            ReDim b(1 To .Count * Fin, 1 To UBound(a, 2) + 1)
            For Each e In .keys
                For i = 1 To Fin
                    n = n + 1
                    .Item(e & i + 1999) = n
                    b(n, 1) = e: b(n, 2) = .Item(e): b(n, 3) = i + 1999
                Next
            Next
            For i = 2 To UBound(a, 1)
                txt = a(i, 1) & a(i, 3)
                If .exists(txt) Then
                    b(.Item(txt), 2) = a(i, 2)
                    b(.Item(txt), 4) = a(i, 4)
                    b(.Item(txt), 5) = "x"
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .Cells(5).Value = "Existant"
                    .Font.Bold = True
                    .Interior.ColorIndex = 45
                    .BorderAround Weight:=xlThin
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub
Edit : j'aurais pu déclarer une constante pour l'année de début, voire utiliser une 2ème IntputBox.
klin89
 

Pièces jointes

  • ilc_li41_1.xls
    290.5 KB · Affichages: 33
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : Boucle macro en insérant lignes

Re le forum,:)

Dans la partie ci-dessous, une erreur s'est glissée :
VB: 
 With .Offset(, .Columns.Count + 1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = a
            .Offset(1).Resize(n, UBound(b, 2)).Value = b
Il faut remplacer :
.Resize(, UBound(a, 2)).Value = a
Cliquez pour agrandir...
par :
.Resize(1, UBound(a, 2)).Value = a
Cliquez pour agrandir...
Voir les 2 codes du post #13 et rectifier.
On peut donc tester avec une valeur supérieure ou égale à l'année 2000
C'est désormais tout bon.

Klin89
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
B
  • Résolu(e)
XL 2016 macro avec boucle
2
Réponses
16
Affichages
1 K
benbella1991
B
F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
2 K
fanou06
F
F
  • Résolu(e)
XL 2019 Enregistrer sous la feuille active dans répertoire du fichier père en vba
2
Réponses
23
Affichages
786
Fabrice16ct
F
L
  • Question
XL 2016 Macro et suppressions de lignes
Réponses
9
Affichages
625
fanfan38
fanfan38
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
1 K
ERIC S
ERIC S
J
  • Résolu(e)
Microsoft 365 Insertion lignes avec macro
Réponses
7
Affichages
1 K
JBL07
J
F
  • Question
Microsoft 365 Répéter en boucle plusieurs actions VBA
Réponses
7
Affichages
668
Deadpool_CC
Deadpool_CC
J
  • Question
XL 2019 Borné une extraction par date
2
Réponses
22
Affichages
2 K
jui42
J
G
  • Question
Microsoft 365 filtrer / défiltrer insertion de ligne automatique - macro qui ne fonctionne pas ou de manière aléatoire
Réponses
4
Affichages
1 K
Grelune
G

Membres actuellement en ligne

17 membres et 125 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 448
Messages
2 088 500
Membres
103 871
dernier inscrit
julienleburton