Macro saut de lignes d'une colonne a une autres

[djunbi]

Bonjour depuis quelques jours j'ai un problème , je n'arrive pas à trouver une macro qui me permettrais d'avancer dans mon travail.
J'ai une base de données avec près de 3000 lignes et j'aimerais insérer 11lignes entre chaque donnée ,. Je n'arrive pas à trouver la macro qui ferais sauter 11 lignes de la colonne A a D
Est ce qu'une âme charitable pourrait me venir en aide ,cela m’évitera des insertions lignes toute la journée et plus ..
cordialement djunbi

 

[Guest]

Re : Macro saut de lignes d'une colonne a une autres

Bonjour,

A tester:

Sub TOTO()
    Dim plage As Range, r As Long
    Dim oldCalculation As XlCalculation
    oldCalculation = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Sheets("Feuil1")
        Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        For r = plage.Rows.Count To 1 Step -1
            Rows(r).Resize(11, 5).Insert xlShiftDown
        Next
    End With
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = True
End Sub

A+

 

[djunbi]

Re : Macro saut de lignes d'une colonne a une autres

Merci HASCO pour la réponse elle marche très bien , il me reste une petite demande , est ce que cela est possible de copier 11 fois la mm lignes dans les insertions effectuer , je voudrais avoir les mm données 11 fois à la suite .
Cordialement djunbi

 

[Guest]

Re : Macro saut de lignes d'une colonne a une autres

Re,

Il fallait le dire en premier lieu. Les questions à tiroirs ne sont pas très appréciées....
Sur la base de ce que je t'ai donné essaye de le faire par toi-même, cela te permettra d'apprendre.

A+

 

[djunbi]

Re : Macro saut de lignes d'une colonne a une autres

Excuse moi pour le manque d'info au premier coups ...... Je vais essayé
A+

 

[djunbi]

Re : Macro saut de lignes d'une colonne a une autres

j'ai essayé de mettre ce code mais le pb c'est que au final j'ai 12 copie , mais il m'en faudrait 11, je bloque je n'arrive pas à le faire.
Pouvez-vous m'aider ?
Cordialement djunbi



Sub test2()


Dim i As Integer
For i = 20 To 2 Step -1

Rows(i & ":" & i).Select
Selection.Copy
Selection.insert Shift:=xlDown

Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.insert Shift:=xlDown
Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.insert Shift:=xlDown
Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.insert Shift:=xlDown
Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy

Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.insert Shift:=xlDown

Rows(i & ":" & (i + 1)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.insert Shift:=xlDown
Next i
End Sub

 

[Guest]

Re : Macro saut de lignes d'une colonne a une autres

Re,

Pour avoir 11 copies au total de la valeur:

Sub TOTO()
     Dim plage As Range, r As Long, valeurs
     Dim oldCalculation As XlCalculation
     oldCalculation = Application.Calculation
     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual
     With Sheets("Feuil1")
         Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
         For r = plage.Rows.Count To 1 Step -1
             With Rows(r).Resize(10, 5)
                .Rows(1).Copy
                .Insert xlDown
             End With
         Next
     End With
     Application.Calculation = oldCalculation
     Application.ScreenUpdating = True
 End Sub

A+

 

[job75]

Re : Macro saut de lignes d'une colonne a une autres

Bonjour djunbi, salut Hasco

Normalement l'exécution avec des tableaux VBA est nettement plus rapide :

Sub InsererLignes()
  Dim n As Byte, plage As Range, tablo1
  Dim ub1&, ub2%, tablo2(), i&, m&, j%
  n = 11 'nombre de lignes identiques, à adapter
  If Application.CountA([A:D]) < 2 Then Exit Sub 'colonnes à étudier
  Set plage = Intersect([A:D], ActiveSheet.UsedRange)
  tablo1 = plage 'un tableau est plus rapide
  ub1 = n * UBound(tablo1)
  If plage.Row + ub1 - 1 > Rows.Count Then _
    MsgBox "Nombre de lignes trop grand !", 48: Exit Sub
  ub2 = UBound(tablo1, 2)
  ReDim tablo2(1 To ub1, 1 To ub2)
  For i = 1 To ub1
    If i Mod n = 1 Then m = m + 1
    For j = 1 To ub2
      tablo2(i, j) = tablo1(m, j)
    Next
  Next
  plage.Resize(ub1) = tablo2
End Sub

Edit : J'ai testé sur 3000 lignes, durées d'exécution sur Win XP/Excel 2003 :

- macro de Hasco => 33,3 secondes.

- macro de job75 => 1,1 seconde

A+

 

[djunbi]

Re : Macro saut de lignes d'une colonne a une autres

Merci à vous 2 pour les réponses ,en effet les 2 solus marche , une peut être plus vite que l'autre mais bon ça fonctionne .

Par contre j'aurai une autre question , j'essaye de faire une macro qui prend en compte une condition , en fait je voudrais faire si données dans colonne A <>de données dans colonne B insérer une cellules vide dans la colonne A ou la données est différente et mettre en couleur dans la colonne B la cellule qui est différente.
J'avais donc pensé le faire avec:
If [A2].Value <> [B2].Value Then
mais après je ne trouve pas la syntaxe pour insérer une cellule , est ce la même :"Selection.insert Shift:=xlDown"

Cordialement benjamin

 

[job75]

Re : Macro saut de lignes d'une colonne a une autres

Re,

J'espère que ma boule de cristal fonctionne bien mais c'est une brave petite.

1) Pour sauter une ligne après chaque série de 11 lignes, modifier la macro ainsi :

Sub InsererLignes()
  Dim n As Byte, plage As Range, tablo1
  Dim ub1&, ub2%, tablo2(), i&, m&, j%
  n = 11 'nombre de lignes identiques, à adapter
  If Application.CountA([A:D]) < 2 Then Exit Sub 'colonnes à étudier
  Set plage = Intersect([A:D], ActiveSheet.UsedRange)
  tablo1 = plage 'un tableau est plus rapide
  ub1 = (n + 1) * UBound(tablo1)
  If plage.Row + ub1 - 1 > Rows.Count Then _
    MsgBox "Nombre de lignes trop grand !", 48: Exit Sub
  ub2 = UBound(tablo1, 2)
  ReDim tablo2(1 To ub1, 1 To ub2)
  For i = 1 To ub1
    If i Mod (n + 1) = 1 Then
      m = m + 1
      If i > 1 Then i = i + 1 'saut de ligne
    End If
    For j = 1 To ub2
      tablo2(i, j) = tablo1(m, j)
    Next
  Next
  plage.Resize(ub1) = tablo2
End Sub

2) Pour colorer la 1ère ligne de chaque série, créer une Mise en forme conditionnelle (MFC).

Fichier joint.

A+

 

[job75]

Re : Macro saut de lignes d'une colonne a une autres

Re,

La 1ère série avait 12 lignes au lieu de 11 ! Voici la bonne macro :

Sub InsererLignes()
  Dim n As Byte, plage As Range, tablo1
  Dim ub1&, ub2%, tablo2(), i&, m As Byte, p&, j%
  n = 11 'nombre de lignes identiques, à adapter
  If Application.CountA([A:D]) < 2 Then Exit Sub 'colonnes à étudier
  Set plage = Intersect([A:D], ActiveSheet.UsedRange)
  tablo1 = plage 'un tableau est plus rapide
  ub1 = (n + 1) * UBound(tablo1)
  If plage.Row + ub1 - 1 > Rows.Count Then _
    MsgBox "Nombre de lignes trop grand !", 48: Exit Sub
  ub2 = UBound(tablo1, 2)
  ReDim tablo2(1 To ub1, 1 To ub2)
  For i = 1 To ub1
    m = i Mod (n + 1)
    If m = 1 Then p = p + 1
    If m Then
      For j = 1 To ub2
        tablo2(i, j) = tablo1(p, j)
      Next
    End If
  Next
  plage.Resize(ub1) = tablo2
End Sub

Par ailleurs j'utilise une autre formule pour la MFC : cela évite des problèmes si on supprime des lignes.

Fichier (2).

A+