Copier coller cellules autre feuille si différentes d'un tableau sous condition

**Gelesty** · 22/03/2018, 10h49

Bonjour,

J'ai besoin d'aide pour une formule VBA pour faire ce qui suit :

J'ai un tableau avec une colonne 1 : Référence, cette référence est équivalente à 4, 5 voir 18 autres références chacune dans une colonne différente (remplacee 1, remplacee 2...)

Je souhaite dans une seconde feuille (tableau 2) (avec seulement 2 colonnes) que j'ai qu'une seule ligne par référence et que dans la seconde colonne j ai toutes les références sans doublons séparé par une virgules ou dans autant de colonne que nécéssaire je ferrais un concatener.

Donc:

Tant que cell(i+1,1)=Cell(i,1) alors copier dans second tableau toutes les valeurs différentes et les concatener séparé par une virgule sur une seule ligne !

faire attention à la taille de chaque ligne toujours différentes

ensuite on passe à la référence suivante ! (j'en ai 400 000!)

Tableau 1

reference	Remplacee 1	Remplacee 2	Remplacee 3	Remplacee 4
M	D	C	B	A
M	B	A
M	D	B	AL
M	AB
Z	T	Y	U
Z	T
Z	U

Tableau 2

Reference	Remplacee
M	D,C,B,A,AL,AB
Z	T,Y,U

UN GRAND MERCI DE VOTRE AIDE ! Je ne fais jamais de VBA mais là les conditions "SI" sont limitée à 8... donc je suis bloqué...

**Gelesty** · 22/03/2018, 11h58

question simple qui me rend malade, pour résoudre mon problème j'essaye de compter le nombre de colonne non vide de la ligne i

donc je voudrais utiliser:

Code :

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

Range ("").SpecialCells(xlCellTypeLastCell).Column

ou

Code :

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

Columns.Count

tout simplement sauf que comment mettre dans un Range un Range("i") (pour ligne i)

j'utilise aussi derco2 =

Code :

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

Sheets("feuil1").Celles(i, Columns.Count).End(xlToLeft)

mais ça me sort la valeur de la dernière cellule non vide et moi je veux le nombre !

d'autres solution ? tout ce que je veux c'est compter le nombre de colonne non vide de la ligne i sur le feuille 1 ! simple quoi !

Merci merci !

**Gelesty** · 22/03/2018, 14h16

pour le comptage de colonne:

Code :

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

DerC=Sheets("feuil1").Cells(i, Cells.Columns.Count).End(xlToLeft).Column

ca avance !

lol

**Gelesty** · 22/03/2018, 15h10

Voici mon code :

il permet de copier coller sur la même ligne toutes les références tant que la ligne du dessous est la meme sinon il copie la nouvelle référence et continu.

Petit problème: ma boucle for j = 1 to 9 ne fonctionne pas car je mélange variable de comptage et variable... je souhaite que le programme tourne pour chaque réfrence unique et pas pour le nombre de ligne, quand je mets j=nombre de ligne, il fait tourner le programme autant de fois que de lignes même si je change la valeur de j..

Il me reste:
- a dire copier que si la valeur n'est pas existante
- concatener sur une même cellule !

merci de votre aide

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
Dim x As Integer
Dim i As Integer
Dim j As Integer
Dim der As Integer
Dim der2 As Integer
x = 0
i = 1
j = 1
Dim nbLignes As Integer
 
nbLignes = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
 
For j = 1 To 9
 
    If Sheets("Feuil1").Cells(i + 1, 1) <> Sheets("Feuil1").Cells(i, 1) Then
            x = i + 1
 
         Range(Sheets("Feuil1").Cells(i + 1, 1), Cells(i + 1, 20)).Copy Destination:=Sheets("Feuil2").Cells(i + 1, 1)
         i = i + 1
 
 
        Do While Sheets("Feuil1").Cells(i + 1, 1) = Sheets("Feuil1").Cells(i, 1)
 
            der = Sheets("feuil1").Cells(i + 1, Cells.Columns.Count).End(xlToLeft).Column - 1
            der2 = Sheets("Feuil2").Cells(x, Cells.Columns.Count).End(xlToLeft).Column
            Range(Sheets("Feuil1").Cells(i + 1, 2), Cells(i + 1, der + 1)).Copy Destination:=Sheets("Feuil2").Cells(x, der2 + 1)
            j = j + 1
 
            i = i + 1
 
 
        Loop
    i = j + 1
 
    End If
 
Next
 
 
End Sub

**Gelesty** · 22/03/2018, 18h41

Bonsoir,

J'ai réussi à copier coller toutes les références sans doublons dans la première cellules non vide et passer à la ligne suivante des que la référence change !
Tout fonctionne !

En revanche j'ai besoin de vous pour la fin ! :
Dans la feuille 3:
-copier coller la première ligne tel quel
-concatenner les valeurs avec un "," pour avoir :

Tableau 2

Reference	Remplacee
M	D,C,B,A,AL,AB
Z	T,Y,U

MERCI ! et en PJ mon fichier !

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
[ATTACH]363436[/ATTACH]
 
 
 
Sub Boucle()
Dim x As Integer
Dim i As Integer
Dim j As Integer
Dim der As Integer
Dim der2 As Integer
Dim derco2 As Integer
Dim k As Integer
Dim l As Integer
Dim doublons As String
 
doublosn = "true"
x = 1
i = 1
j = 1
l = 2
k = 2
 
 
Dim nbLignes As Integer
 
nbLignes = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
 
For j = 1 To nbLignes - 1
 
 
    If Sheets("Feuil1").Cells(i + 1, 1) <> Sheets("Feuil1").Cells(i, 1) Then
            x = x + 1
 
         Range(Sheets("Feuil1").Cells(i + 1, 1), Cells(i + 1, 20)).Copy Destination:=Sheets("Feuil2").Cells(x, 1)
         i = i + 1
 
 
        Do While Sheets("Feuil1").Cells(i + 1, 1) = Sheets("Feuil1").Cells(i, 1)
 
            der = Sheets("feuil1").Cells(i + 1, Cells.Columns.Count).End(xlToLeft).Column - 1
            der2 = Sheets("Feuil2").Cells(x, Cells.Columns.Count).End(xlToLeft).Column
          For l = 2 To der + 1
            k = 2
            doublons = "False"
 
            For k = 2 To der2
            If Sheets("Feuil1").Cells(i + 1, l).Value = Sheets("Feuil2").Cells(x, k).Value Then
                    doublons = "true"
            End If
            Next
 
            If doublons = "False" Then
                Sheets("Feuil1").Cells(i + 1, l).Copy Destination:=Sheets("Feuil2").Cells(x, der2 + 1)
            End If
 
          Next
            j = j + 1
 
            i = i + 1
 
 
        Loop
    i = j + 1
 
    End If
 
Next
 
End Sub

**Gelesty** · 23/03/2018, 17h01

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Sub Boucle()
Dim C As Long
Dim CLasseur4(100) As Integer
Dim reponse  As String
Dim x As Integer
Dim i As Integer
Dim j As Integer
Dim der As Integer
Dim der2 As Integer
Dim derco2 As Integer
Dim k As Integer
Dim l As Integer
Dim doublons As String
Dim nbLignes As Integer
Dim nbLignes2 As Integer
Dim nbColonnes As Integer
doublosn = "true"
nbColonnes = 0
Dim b As Integer
Dim v As Integer
x = 1
i = 1
j = 1
l = 2
k = 2
 
 
 
 
nbLignes = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
 
 
For j = 1 To nbLignes - 1
 
 
    If Sheets("Feuil1").Cells(i + 1, 1) <> Sheets("Feuil1").Cells(i, 1) Then
            x = x + 1
 
         Range(Sheets("Feuil1").Cells(i + 1, 1), Cells(i + 1, 20)).Copy Destination:=Sheets("Feuil2").Cells(x, 1)
         i = i + 1
 
 
        Do While Sheets("Feuil1").Cells(i + 1, 1) = Sheets("Feuil1").Cells(i, 1)
 
            der = Sheets("feuil1").Cells(i + 1, Cells.Columns.Count).End(xlToLeft).Column - 1
            der2 = Sheets("Feuil2").Cells(x, Cells.Columns.Count).End(xlToLeft).Column
          For l = 2 To der + 1
            k = 2
            doublons = "False"
 
            For k = 2 To der2
            If Sheets("Feuil1").Cells(i + 1, l).Value = Sheets("Feuil2").Cells(x, k).Value Then
                    doublons = "true"
            End If
            Next
 
            If doublons = "False" Then
                Sheets("Feuil1").Cells(i + 1, l).Copy Destination:=Sheets("Feuil2").Cells(x, der2 + 1)
            End If
 
          Next
            j = j + 1
 
            i = i + 1
 
 
        Loop
    i = j + 1
 
    End If
Next
 
Sheets("Feuil2").Columns(1).Copy Sheets("Feuil3").Columns(1)
nbLignes2 = Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row
 
For b = 2 To nbLignes2
nbColonnes = Sheets("Feuil2").Cells(b, 2).End(xlToRight).Column
 
    For v = 2 To nbColonnes
        Sheets("Feuil3").Cells(b, 2) = Sheets("Feuil3").Cells(b, 2) & ";" & Sheets("Feuil2").Cells(b, v)
    Next
Next
 
For i = 2 To nbLignes2
      s = Sheets("Feuil3").Cells(i, 2)
      Sheets("Feuil3").Cells(i, 2) = Right(s, Len(s) - 1)
   Next
 
End Sub

**Pierre Fauconnier** · 23/03/2018, 20h45

Salut.

Je ne sais pas avec quelle version tu travailles, mais depuis XL2007, on peut imbriquer 64 SI(), même si ce n'est évidemment pas conseillé.

Souvent, l'organisation du classeur peut être revue pour utiliser des fonctions telles que RECHERCHEV, INDEX/EQUIV, ...

**Gelesty** · 26/03/2018, 10h31

Bonjour Pierre,

Un grand merci de ton retour ! et surtout des modifications que tu as apportées à mon post, je tacherais d'apprendre à utiliser les différentes fonctions pour mes futures demandes pour aider à la lisibilité et à l'entraide entre chacun

les 64 SI ()... je vais vérifier ma version et réessayer car ma première formule était basé sur des SI() à mais fonctionnait bien aussi

En revanche quand je lance ma formule, il me dit : "erreur d'exécution '6': Dépassement de capacité"

Copier coller cellules autre feuille si différentes d'un tableau sous condition

Macros et VBA Excel

Discussions similaires

Partager

Partager