Dupliquer ligne entiere selon valeur dans une colonne

**Freudsw** · 09/03/2017, 16h52

Bonjour,

Je vous expliques mon probleme : je dispose de deux sources de données (deux onglets Excel) avec plusieurs colonnes remplies par différentes données.

Dans le premier onglet, je me base sur deux colonnes : la premiere colonne contient différentes valeurs (exemples : des chiffres (1,2,35,9,15,235.....). à coté de chaque chiffre dans la deuxieme colonne j'ai à chaque fois la même valeur (XXX).

Dans le deuxième onglet, j'ai un tableau de deux colonnes; dans la premiere colonne, je dispose des mêmses valeurs que j'ai déja dans la premiere colonne du premier onglet, mais qui sont répétées plusieurs fois selon le cas.

En gros , par exemple le chiffre 1 est répeté sur 5 lignes, car dans la deuxieme colonne j'ai 5 valeurs possibles devant le 1 et le 2 est répété 3 fois. comme suit :

1 A
1 B
1 C
1 D
1 E
2 T
2 X
2 O

Mon objectif c'est de réussir à dupliquer dans mon premier onglet la ligne qui contient le 1 pour obtenir 5 lignes avec les différentes valeurs et dupliquer aussi la ligne qui contient la valeur 2 sur 3 lignes en rajoutant a chaque fois leurs valeurs respective dans une autre colonne ainsi de suite...

J'ai fait un code qui me permet de rajouter ses valeurs mais sur la meme ligne, or que moi je veux vraiment créer des lignes a chaque fois.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Import2()
Dim source As Workbook
Dim oRng As Range
Dim i, n, a, b, dcolone, j As Integer
Dim stRep As String
Dim stFichier As String
Dim Fichier As String
Dim nom As String
Dim W As Worksheet
Dim dernligne, dernligne2 As Long
Dim Arrn()
 
 
Application.ScreenUpdating = False
 
Worksheets("TA-0990-TG13B").Activate
With Worksheets("TA-0990-TG13B")
 
.Rows("1").AutoFilter Field:=10, Criteria1:="XXX"
 
n = .Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
 
ReDim Arrn(2 To n)
 
For i = 2 To n
 
Arrn(i) = Cells(i, 9)
 
 
 If Worksheets("TA-0990-TG14A").AutoFilterMode Then .Cells.AutoFilter
 
    Worksheets("TA-0990-TG14A").Rows("1").AutoFilter Field:=6, Criteria1:=Arrn(i)
 
  a = Worksheets("TA-0990-TG14A").Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
 
 
    Worksheets("TA-0990-TG14A").Range("G2:G" & a).Copy
    .Range("K" & i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True
 
Next i
 
End With
 
 
End Sub

Je vous remercie par avance pour votre aide.

Cordialement,

Freudsw

**Menhir** · 09/03/2017, 19h31

Je pense que tu te compliques la vie.
En particulier, je n'ai pas compris pourquoi tu utilises des filtres. Rien dans ton explication ne les justifie.
A moins que tu aies récupéré un code sur Internet sans vraiment chercher à comprendre comment il fonctionnait.

En supposant que tes lignes sources soient en colonnes A et B et commencent à la ligne 2.
En supposant que "TA-0990-TG13B" soit la source et "TA-0990-TG14A" la cible.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Import2()
   Dim Ligne As Long, I As Long
   Dim RSource As Range
   Dim WSource As Worksheet, WDest As Worksheet
 
   Set WSource = Worksheets("TA-0990-TG13B")
   Set WDest = Worksheets("TA-0990-TG14A")
 
   WDest.Columns("A:B").ClearContents
   Ligne = 2
 
   For Each RSource In WSource.Range("A1", WSource.Cells(1, Rows.Count).End(xlUp))
      For I = 1 To Len(RSource.Offset(0, 1).Value)
         WDest.Cells(Ligne, 1).Value = RSource.Value
         WDest.Cells(Ligne, 2).Value = Mid(RSource.Value, I, 1)
         Ligne = Ligne + 1
       Next I
   Next RSource
 
End Sub

C'est du code tapé à l'arrache. Il y aura peut-être un peu de débugage à faire.

**Freudsw** · 10/03/2017, 10h45

Bonjour,

Merci pour la réponse.

Non ce n'est pas un code récupéré sur internet. Ma demande concerne juste sur la partie ou je bloque de ma Macro. En réalité dans la colonne ou j'avais dit qu'il y avait que des "xxx", il y a d'autre valeur, c'est pour cela que j'ai fait le filtre. Aussi, mes deux onglets contiennent plusieurs colonnes, j'ai dit que j'avais deux colonnes pour simplifier ...

Je vais tester ton code et je te reviens.

Merci encore

Cordialement,

Freudsw.

**Menhir** · 10/03/2017, 11h09

Envoyé par Freudsw

En réalité dans la colonne ou j'avais dit qu'il y avait que des "xxx", il y a d'autre valeur, c'est pour cela que j'ai fait le filtre. Aussi, mes deux onglets contiennent plusieurs colonnes, j'ai dit que j'avais deux colonnes pour simplifier ...

Du coup, tes explications ne correspondaient pas à ton code, ce qui rendait le code incompréhensible.

Je vais tester ton code et je te reviens.

Je viens de m'apercevoir que j'avais oublié dans mon code un Ligne = Ligne + 1.
Je l'ai corrigé.

**Freudsw** · 10/03/2017, 11h40

Re-bonjour

Effectivement, je n'ai pas été clair dans mon explication.

je vais expliquer mon souci avec un exemple concret : j'ai deux Onglets ;

Dans l'onglet 1, je dispose de trois colonnes comme suit : compte, dimension et occurence.

Compte	dimension	occurence
124	1		1
124	1		2
125	2		5
126	1		X
128	1		3
128	2		5
128	2		6
130	2		X

En gros, le tableau veut dire que pour le compte 124 j'ai la dimension 1 qui peut avoir deux occurence 1 et 2. le compte 126 lui aussi dispose de la dimension 1 et le X veut dire qu'il accepte toutes les occurences possibles pour cette dimension (ces occurence, je peux les trouver dans le deuxième onglet)

le deuxieme onglet donc me donne toutes les occurences possibles pour chaque dimension comme suit :

Dimension	Occurence
1		1
1		2
1		3
2		5
2		6
2		7

Donc, ce que je veux faire, c'est de remplacer le x dans mon premier onglet par toutes les valeurs possibles que je trouve dans l'onglet 2 et ce en dupliquant a chaque fois les lignes pour obtenir ça:

Compte	dimension	occurence
124	1		1
124	1		2
125	2		5
126	1		1
126	1		2
126	1		3
128	1		3
128	2		5
128	2		6
130	2		5  
130	2		6
130	2		7

j'espere avoir été clair cette fois ci.

Donc quand tu éffaces le contenu de la feuille de destination, c'est pas vraiment ce que je veux faire.

je vais essayer d'adapter ton code à ce que je veux faire, a moins si tu me proposes autre chose.

Je te remercie par avance.

Cordialement,

Freudsw

Dans l'exemple, l'espace veut dire que je change de colonne...

Merci encore

**BENNASR** · 10/03/2017, 17h38

bonsoir
j'ai arrivé à bricolé ça pour toi
l'idée est que si la colonne c = X il va chercher le nombre des occurrence de cette dimension et insère le nombre des lignes approprié
reste à remplir les lignes mais c'est l'heure de weekend

Attention je suis débutant et bricoleur...et le lundi pas à pas en arrivera inchallah
bonne weekend à tous

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test()
Dim dernligne As Long
With Sheets("feuil1")
dernligne = .Range("A" & Rows.Count).End(xlUp).Row
For i = dernligne To 1 Step -1
   If .Cells(i, 3).Value Like "X" Then
   valrech = .Cells(i, 2).Value
   c = WorksheetFunction.CountIf(Sheets("feuil2").Range("A:A"), valrech)
   If c > 0 Then Rows(i).Resize(c - 1).Insert
   End If
Next i
End With
End Sub

**Freudsw** · 13/03/2017, 11h31

Bonjour,

Merci pour ton aide BENNASR.

J'ai fait quelques modifs pour ton code et j'ai reussi à rajouter un bout de code qui me permet de remplir les cellules inserées. Par contre il me manque juste la derniere colonne à remplir avec les différentes occurences correspondantes à la dimension "valrech" trouvée.

voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim Orng As Range
Dim dernligne, i, j, dligne As Long
With Sheets("TG 8.3 resultat")
dernligne = .Range("A" & Rows.Count).End(xlUp).Row
For i = dernligne To 1 Step -1
   If .Cells(i, 5).Value Like "XXX" Then
   valrech = .Cells(i, 4).Value
   c = WorksheetFunction.CountIf(Sheets("TG 8.3 source").Range("A:A"), valrech)
  If c > 0 Then Sheets("TG 8.3 resultat").Rows(i + 1).Resize(c).Insert
   End If
Next i
 
Set Orng = .Range("A2")
dligne = .Range("E" & Rows.Count).End(xlUp).Row
 
    For i = 0 To dligne - 1
    For j = 0 To 3
    If Orng.Offset(i, j) = "" Then
    Orng.Offset(i, j).Value = Orng.Offset(i - 1, j)
    End If
    Next j
    Next i
 
End With
End Sub

y a t-il un moyen qui me permet de remplir la derniere colonne avec les variables trouvées à chaque fois ??

Merci pour ton aide.

Cordialement,

Freudsw.

**Freudsw** · 13/03/2017, 17h21

Bonjour,

J'ai reussi à trouver le code qui fonctionne parfaitement.

je le mets ci-dessous au cas ou d'autres en auront besoin :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim Orng As Range
Dim dernligne, i, j, dligne As Long
With Sheets("production resultat")
dernligne = .Range("A" & Rows.Count).End(xlUp).Row
For i = dernligne To 1 Step -1
   If .Cells(i, 5).Value Like "XXX" Then
   valrech = .Cells(i, 4).Value
   c = WorksheetFunction.CountIf(Sheets("production source").Range("A:A"), valrech)
  If c > 0 Then Sheets("production resultat").Rows(i + 1).Resize(c).Insert
 
 
 
   If Worksheets("production source").FilterMode = True Then Worksheets("production source").ShowAllData
       Worksheets("production source").Rows("1").AutoFilter Field:=1, Criteria1:=valrech
        With Worksheets("production source").UsedRange
            If Worksheets("production source").Columns(3).SpecialCells(xlCellTypeVisible).Count > 0 Then
 
            dernligne = Worksheets("production source").Range("A" & Rows.Count).End(xlUp).Row
 
            Worksheets("production source").Range("B2:B" & dernligne).Copy ThisWorkbook.Worksheets("production resultat").Cells(i + 1, 5)
 
            End If
        End With
 
End If
Next i
 
Set Orng = .Range("A2")
dligne = .Range("E" & Rows.Count).End(xlUp).Row
 
    For i = 0 To dligne - 1
    For j = 0 To 3
    If Orng.Offset(i, j) = "" Then
    Orng.Offset(i, j).Value = Orng.Offset(i - 1, j)
    End If
    Next j
    Next i
 
End With
End Sub

Merci encore pour votre aide.

Cordialement,

Freudsw

**BENNASR** · 14/03/2017, 09h55

BONJOUR
Moi j'ai bricolé ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim dernligne As Long
Dim j As Integer
Dim k As Integer
With Sheets("feuil1")
dernligne = .Range("A" & Rows.Count).End(xlUp).Row
For k = dernligne To 1 Step -1
   If .Cells(k, 3).Value Like "X" Then
   valrech = .Cells(k, 2).Value
   c = WorksheetFunction.CountIf(Sheets("feuil2").Range("A:A"), valrech)
   If c > 0 Then Rows(k + 1).Resize(c - 1).Insert
 
   For j = 0 To c - 1
   .Cells(k + j, 1).Value = .Cells(k, 1)
   .Cells(k + j, 2).Value = .Cells(k, 2)
   .Cells(k + j, 3).Value = .Cells(k, 3)
   Next j
   End If
 
Next k
End With
'******************remplir colonnes
 
   Dim wSh1 As Worksheet, wSh2 As Worksheet
   Dim derlig As Long
   Dim MemeProduit As Range, kL2 As Long
   Set wSh1 = ActiveWorkbook.Worksheets("feuil1")
   Set wSh2 = ActiveWorkbook.Worksheets("Feuil2")
   derlig = wSh1.Range("A" & Rows.Count).End(xlUp).Row
   j = 0
   kL2 = 1
   For i = 2 To derlig
   If wSh1.Cells(i, 3) Like "X" Then
      Set MemeProduit = wSh2.Range("A" & kL2 & ":A" & derlig).Find(wSh1.Cells(i, 2), LookIn:=xlValues)
       If MemeProduit Is Nothing Then
         '--- le produit indiqué dans wSh1 n'est pas mentionné dans wSh2
      Else
 
      If MemeProduit <> 0 Then
         kL2 = MemeProduit.Row
         wSh1.Cells(i, 3) = wSh2.Cells(kL2, 2)
      End If
   End If
    End If
   Next i
End Sub

Dupliquer ligne entiere selon valeur dans une colonne [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager