Discussion :

[rashka]

Bonsoir à tous,

Je souhaite faire un tri en vba permettant d'obtenir des données depuis la feuille1 vers la feuille2.

Voilà ce que j'ai.

feuille1, c'est les données brute d'un csv sous forme :
(ex : pierre et data1 sur une même ligne et sur des cellules différentes)
pierre | data1
bob | data1
michel | data2
michelle | data1
pierre | data2
hugo | data1
severine | data3
bob | data3
.... y en a plus de 2000 lignes


feuille2 que je souhaiterai avoir depuis la feuille 1, les prénoms doivent être sur la même ligne sur des cellules différentes ou sur un combobox

data1 | pierre | bob | michelle | hugo
data2 | michel | pierre
data3 | bob | severine


l'ordre des prénoms ne sont pas important.

J'espère que je m'exprime bien

Merci d'avance pour votre aide.

Amicalement,

Rashka

[laetitia]

bonjour rashka le forum

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
Option Explicit
Sub es()
 Dim c, d As Variant, m As Object, x As Integer
    Application.ScreenUpdating = False
        With Sheets("feuil1")
        Set m = CreateObject("Scripting.Dictionary")
        For Each c In .Range("b2", .[b65000].End(xlUp))
         m(c.Value) = IIf(m.Exists(c.Value), m(c.Value) + 1, 1)
        Next c
      With Sheets("feuil2")
         .Cells.ClearContents: [a1].Select
         .[a2].Resize(m.Count, 1) = Application.Transpose(m.keys)
      End With: End With
       With Sheets("feuil2")
       For Each c In .Range("a2", .[a65000].End(xlUp))
      With Sheets("feuil1")
       For Each d In .Range("b2", .[b65000].End(xlUp))
       If c = d Then
        c.Offset(, 1 + x) = d.Offset(, -1)
                 x = x + 1
               End If
              Next d
            x = 0
         End With
      Next c
  .[a2:bze20000].Sort Key1:=.Range("a2"), Order1:=xlAscending, Header:=xlGuess
  End With
End Sub

[pgz]

Bonjour.

Sans précision, j'ai considéré que dans la 2ème feuille les prénoms d'un même ligne sont dans des cellules différentes, ce qui limite le nombre de ces prénoms.

Voilà une procédure qui doit faire ce que tu demandes avec, en plus, les data rangés dans l'ordre croissant de haut en bas et sur chaque ligne les prénoms par ordre alpha de gauche à droite.

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
Sub subReorganise()
Dim sh1 As Excel.Worksheet, sh2 As Excel.Worksheet
Dim l1 As Long, nbl1 As Long, nbl2 As Long, l2 As Long, j2 As Integer
Dim vTL As Variant, vData As Variant, vTE As Variant
Dim nbPers As Integer, nbMaxPers As Integer
 
Set sh1 = ThisWorkbook.Worksheets(1)
Set sh2 = ThisWorkbook.Worksheets(2)
 
'nb lignes à traiter
nbl1 = sh1.Cells(Application.Rows.Count, 1).End(xlUp).Row
 
'tri des données
sh1.Range("A1:B" & nbl1).Sort sh1.Range("B:B"), xlAscending, sh1.Range("A:A"), , xlAscending
 
'chargement des données
vTL = sh1.Range("A1:B" & nbl1).Value
 
'calcul du nombre max de personnes associées à une valeur, et du nombre de datas différents
nbMaxPers = 0
nbPers = 0
vData = Null
nbl2 = 0
For l1 = 1 To nbl1
    If vData = vTL(l1, 2) Then
        nbPers = nbPers + 1
    Else
        If nbPers > nbMaxPers Then nbMaxPers = nbPers
        vData = vTL(l1, 2)
        nbl2 = nbl2 + 1
        nbPers = 1
    End If
Next l1
 
'vérifier que le nombre de personnes max n'est pas trop grand
If nbMaxPers + 1 > Application.Columns.Count Then
    MsgBox "la feuille n'a pas assez de colonnes pour afficher le résultat."
    GoTo Sortie
End If
 
'nettoyage de la feuille 2
sh2.UsedRange.Clear
 
'chargement d'un tableau de la bonne taille
vTE = sh2.Range(sh2.Range("A1"), sh2.Cells(nbl2, nbMaxPers + 1)).Value
 
'remplissage du tableau d'écriture
l2 = 0
j2 = 1
vData = Null
For l1 = 1 To nbl1
    If vData = vTL(l1, 2) Then
        vTE(l2, j2) = vTL(l1, 1)
        j2 = j2 + 1
    Else
        l2 = l2 + 1
        vData = vTL(l1, 2)
        vTE(l2, 1) = vTL(l1, 2)
        vTE(l2, 2) = vTL(l1, 1)
        j2 = 3
    End If
Next l1
 
'copier vTE dans feuille 2
sh2.Range(sh2.Range("A1"), sh2.Cells(nbl2, nbMaxPers + 1)).Value = vTE
sh2.Range("A1").Value = vTE
 
Sortie:
vTL = Null
vTE = Null
Set sh1 = Nothing
Set sh2 = Nothing
 
End Sub

Bien cordialement,

PGZ

[rashka]

Merci Merci Merci pgz
Merci pour notre association cette contribution, je me souviendrai de toi, tout fonctionne parfaitement !

J'ai pas testé le script de laetitia, mais je pense que c'est tout bon également.

Encore mille merci.