code vba pour insérer et copier des lignes

Version imprimable

10/05/2021, 00h39
gwenngeocaz

1 pièce(s) jointe(s)

code vba pour insérer et copier des lignes

Bonjour, je ne sais pas si c'est possible mais j'ai des lignes dans un tableau et je souhaite insérer des lignes le nombre de fois que la valeur indiquée dans la colonne B et copier cette même ligne. Je ne sais pas si je suis clair alors voici un exemple:

Pièce jointe 597515

Merci d'avance

Citation:

Envoyé par gwenngeocaz

Bonjour,

A tester :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
Option Explicit
 
Sub DupliquerLesLignes()
 
Dim I As Long, J As Long, LigneDebut As Long, LigneFin As Long, NbPresents As Long
Dim Liste As Range
 
    With ActiveSheet
         LigneDebut = 3
         LigneFin = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set Liste = .Range(.Cells(LigneDebut, 1), .Cells(LigneFin, 1))
 
         For I = 1 To Liste.Count
            With Liste(I)
                 NbPresents = WorksheetFunction.CountIf(Liste, .Value)
                 If NbPresents < .Offset(0, 1) Then
                    For J = 1 To .Offset(0, 1) - NbPresents
                        .EntireRow.Copy Destination:=ActiveSheet.Cells(LigneFin + 1, 1)
                        LigneFin = LigneFin + 1
                    Next J
                 End If
            End With
         Next I
    End With
 
    Set Liste = Nothing
 
End Sub

Citation:

Envoyé par gwenngeocaz

S'il faut trier le tableau :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 
Sub DupliquerLesLignesAvecTri()
 
Dim I As Long, J As Long, LigneDebut As Long, LigneFin As Long, NbPresents As Long
Dim Liste As Range
 
    With ActiveSheet
         LigneDebut = 3
         LigneFin = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set Liste = .Range(.Cells(LigneDebut, 1), .Cells(LigneFin, 1))
 
         For I = 1 To Liste.Count
            With Liste(I)
                 NbPresents = WorksheetFunction.CountIf(Liste, .Value)
                 Debug.Print Liste(I) & " : " & WorksheetFunction.CountIf(Liste, .Value)
                 If NbPresents < .Offset(0, 1) Then
                    For J = 1 To .Offset(0, 1) - NbPresents
                        .EntireRow.Copy Destination:=ActiveSheet.Cells(LigneFin + 1, 1)
                        LigneFin = LigneFin + 1
                    Next J
                 End If
            End With
         Next I
 
         ' Tri du tableau
         TrierUnTableau ActiveSheet, LigneDebut, 1
 
    End With
 
    Set Liste = Nothing
 
End Sub
 
Sub TrierUnTableau(ByVal FeuilleATrier As Worksheet, ByVal LigneDeTitre As Long, ByVal ColonneATrier As Long)
 
Dim DerniereColonne As Long
Dim DerniereLigne As Long
 
Dim AireATrier As Range
Dim AireColonne As Range
 
    With FeuilleATrier
 
         DerniereColonne = .Cells(LigneDeTitre, .Columns.Count).End(xlToLeft).Column
         DerniereLigne = .Cells(.Rows.Count, ColonneATrier).End(xlUp).Row
 
         If DerniereLigne > LigneDeTitre Then
            Set AireATrier = .Range(.Cells(LigneDeTitre, 1), .Cells(DerniereLigne, DerniereColonne))
            Set AireColonne = .Range(.Cells(LigneDeTitre, ColonneATrier), .Cells(DerniereLigne, ColonneATrier))
 
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=AireColonne, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                 .SetRange AireATrier
                 .Header = xlYes
                 .MatchCase = False
                 .Orientation = xlTopToBottom
                 .SortMethod = xlPinYin
                 .Apply
             End With
 
             Set AireColonne = Nothing
             Set AireATrier = Nothing
 
          End If
 
    End With
 
End Sub

1 pièce(s) jointe(s)

Citation:

Envoyé par Eric KERGRESSE

Bonjour,

A tester :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
Option Explicit
 
Sub DupliquerLesLignes()
 
Dim I As Long, J As Long, LigneDebut As Long, LigneFin As Long, NbPresents As Long
Dim Liste As Range
 
    With ActiveSheet
         LigneDebut = 3
         LigneFin = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set Liste = .Range(.Cells(LigneDebut, 1), .Cells(LigneFin, 1))
 
         For I = 1 To Liste.Count
            With Liste(I)
                 NbPresents = WorksheetFunction.CountIf(Liste, .Value)
                 If NbPresents < .Offset(0, 1) Then
                    For J = 1 To .Offset(0, 1) - NbPresents
                        .EntireRow.Copy Destination:=ActiveSheet.Cells(LigneFin + 1, 1)
                        LigneFin = LigneFin + 1
                    Next J
                 End If
            End With
         Next I
    End With
 
    Set Liste = Nothing
 
End Sub

Merci beaucoup c'est presque parfait sauf que ca ne fonctionne pas dans le cas ou les valeurs des cellules de la colonne A sont identique

10/05/2021, 10h30
Invité

Citation:

Envoyé par gwenngeocaz

Le problème est mal posé.
10/05/2021, 14h02
gwenngeocaz

1 pièce(s) jointe(s)

Désoler si je me suis mal exprimé, c'est la première fois pour moi sur un forum. Donc je réexplique suivant l'exemple :
Donc je souhaite que la 1ère ligne soit dupliquée 2 fois (valeur de la colonne B) et que la 2ème ligne soit dupliquée 3 fois (valeur de la colonne B) etc..

Bonjour

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
Sub insertLignes1()
  Dim nlh%, nlb%, nc%, i%, J%
  Dim tmp1, tmp2
  Dim tb()
  nlh = Range("A1").End(xlDown).Row
  nlb = Range("A65000").End(xlUp).Row
  nc = Cells(nlh, Cells.Columns.Count).End(xlToLeft).Column
  For i = nlb To nlh Step -1
    tmp1 = Cells(i, 1).Cells & " " & Cells(i, 2).Cells
    tmp2 = Cells(i - 1, 1).Cells & " " & Cells(i - 1, 2).Cells
 
    If tmp1 <> tmp2 And Cells(i, 2).Cells > 1 Then
      tb = Range(Cells(i, 1), Cells(i, nc)).Cells
      For J = 1 To Cells(i, 2).Cells - 1
        Rows(i).Insert Shift:=xlDown
        Range(Cells(i, 1), Cells(i, nc)) = tb
      Next J
    End If
  Next i
End Sub

10/05/2021, 15h23
Invité

Citation:

Envoyé par gwenngeocaz

Vous ne décrivez pas correctement vos règles de gestion. Quels cas peut-on rencontrer dans la liste initiale ? Y a-t-il des doublons possibles ? Si oui quelle valeur doit être prise en compte s'il y a homonymie ?
10/05/2021, 16h10
gwenngeocaz

Excusez moi si je ne suis pas clair mais je ne sais pas quoi dire de plus que le fait que je dois dupliquer chacune des lignes le nombres de fois inscrit dans la cellule de cette ligne sur la colonne B. Chaque ligne peut comporter des cellules identiques aux lignes précédentes. Mais toutes les lignes du tableau de base doivent être dupliquée
10/05/2021, 16h25
Invité

Citation:

Envoyé par gwenngeocaz

Vous ne répondez pas aux questions. Dans votre message d'origine, seulement 2 cas distincts dans votre tableau. Ensuite, vous indiquez que le code ne fonctionne pas lorsqu'il y a deux cas identiques, mais ce cas n'est pas identifié au départ et vous n'indiquez pas ce qui doit être choisi si pour ce cas on a deux valeurs distinctes en colonne B.

Je dois raisonner comme un bourrin... Le mieux est que j'arrête cette discussion, d'autres auront mieux compris que moi et vous aurez la bonne réponse.

Bonne chance.