Discussion :

[hugo1674]

Bonsoir,

Je rencontre deux problèmes pour trier les données du fichier ci-joint et malgré de multiples tentatives pour les résoudre, je n'arrive toujours pas à mes fins.

voici le code à exécuter :

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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
Option Explicit
 
Public Function derligneColonne(sheetsBDD As String, by As String) As Long
 
Dim j As Long
 
j = 2
 
If by = "Ligne" Then
 
  Do
 
     j = j + 1
 
  Loop While Sheets(sheetsBDD).Cells(j, 1).Value <> ""
 
Else
 
  Do
 
     j = j + 1
 
  Loop While Sheets(sheetsBDD).Cells(1, j).Value <> ""
 
End If
 
derligneColonne = j - 1
 
End Function
 
Public Sub Copy(sheetsBDD As String, crit As String, sheetsToCopy As String)
 
Dim ligne As Long
Dim col As Long
Dim ligneToCopy As Long
Dim i As Long
Dim j As Long
 
col = derligneColonne(sheetsBDD, "col")
 
' Copier le titre
 
For j = 1 To col
 
Sheets(sheetsToCopy).Cells(1, j).Value = Sheets(sheetsBDD).Cells(2, j).Value
 
Next j
 
ligne = derligneColonne(sheetsBDD, "Ligne")
ligneToCopy = derligneColonne(sheetsToCopy, "Ligne") + 1
 
' Copier les valeurs
 
For i = 3 To ligne
 
    If Sheets(sheetsBDD).Cells(i, 1).Value = crit Then
 
       For j = 1 To col
 
           Sheets(sheetsToCopy).Cells(ligneToCopy, j).Value = Sheets(sheetsBDD).Cells(i, j).Value
 
       Next j
 
       ligneToCopy = ligneToCopy + 1
 
    End If
 
Next i
 
End Sub
Public Function VerifAppartenance(SheetsVerif As String, colonne As Long, critere As String, vectorbeg As Long, VectorLenght As Long) As Long
Dim i As Long
Dim result As Long
result = 0
 
For i = vectorbeg To VectorLenght
 
      If Sheets(SheetsVerif).Cells(i, colonne).Value = critere Then
 
         result = result + 1
 
      Else
 
         result = result + 0
 
      End If
 
Next i
 
VerifAppartenance = result
 
End Function
 
Public Sub crit(sheetsBDD As String)
 
Dim i As Long
Dim derligne As Long
Dim derligneBDD As Long
Dim firstCrit As String
Dim verif As Long
 
Sheets.Add(After:=Worksheets(Worksheets.Count)).name = "Criteres"
Sheets("Criteres").Cells(1, 1).Value = "Criteres"
derligneBDD = derligneColonne(sheetsBDD, "Ligne")
firstCrit = Sheets(sheetsBDD).Cells(3, 1).Value
 
Sheets("Criteres").Cells(2, 1).Value = firstCrit
 
For i = 3 To derligneBDD
 
    firstCrit = Sheets(sheetsBDD).Cells(i, 1).Value
 
    derligne = derligneColonne("Criteres", "Ligne")
 
    verif = VerifAppartenance("Criteres", 1, firstCrit, 2, derligne)
 
    If verif > 0 Then
 
       firstCrit = firstCrit
 
    Else
 
       Sheets("Criteres").Cells(derligne + 1, 1).Value = firstCrit
 
    End If
 
Next i
 
End Sub
 
Sub CreateCopy(sheetsBDD As String)
Dim i As Long
Dim derligneCritere As Long
Dim critere As String
Dim name As String
 
Call crit(sheetsBDD)
derligneCritere = derligneColonne("Criteres", "Ligne")
 
For i = 2 To derligneCritere
 
    critere = Sheets("Criteres").Cells(i, 1).Value
 
    name = critere
 
    Sheets.Add(After:=Worksheets(Worksheets.Count)).name = name
 
    Call Copy(sheetsBDD, critere, name)
 
Next i
 
End Sub
 
Sub essai()
CreateCopy ("Transaction Listing")
'MsgBox VerifAppartenance("Feuil3", 1, "ZZ", 2, 10)
MsgBox "Termin? Grand Patron"
End Sub

Premier problème :
Les lignes ne se recopient pas entièrement dans les nouvelles feuilles, seulement les deux premières colonnes.

Deuxième problème :
Plusieurs feuilles du même nom se forment, ex : deux feuilles "AA", deux feuilles "UG1",... après l'exécution du code, les donnés sont séparées dans les différentes. Il faudrait une seule feuille avec toutes les données dedans.

Je ne pense pas que les problèmes soient très compliqués à résoudre mais je n'y arrive pas tout de même.

Merci d'avance pour votre aide.

[ARTURO83]

Bonjour,

Premier problème :
Les lignes ne se recopient pas entièrement dans les nouvelles feuilles, seulement les deux premières colonnes.

ici, sur la ligne "Loop while" il faut mettre 2 à la place de un(ici en rouge):

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Function derligneColonne(sheetsBDD As String, by As String) As Long
    Dim j As Long
    j = 2
    If by = "Ligne" Then
      Do
         j = j + 1
      Loop While Sheets(sheetsBDD).Cells(j, 1).Value <> ""
    Else
      Do
         j = j + 1
      Loop While Sheets(sheetsBDD).Cells(2, j).Value <> ""
    End If
    derligneColonne = j - 1
End Function

Deuxième problème :
Plusieurs feuilles du même nom se forment, ex : deux feuilles "AA", deux feuilles "UG1",... après l'exécution du code, les donnés sont séparées dans les différentes. Il faudrait une seule feuille avec toutes les données dedans.

Les valeurs des grades sont différentes, certaines contiennent un espace à la fin et d'autres pas, exemple: "T" et "T "

Cdlt

[hugo1674]

Bonjour,



ici, sur la ligne "Loop while" il faut mettre 2 à la place de un(ici en rouge):

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Function derligneColonne(sheetsBDD As String, by As String) As Long
    Dim j As Long
    j = 2
    If by = "Ligne" Then
      Do
         j = j + 1
      Loop While Sheets(sheetsBDD).Cells(j, 1).Value <> ""
    Else
      Do
         j = j + 1
      Loop While Sheets(sheetsBDD).Cells(2, j).Value <> ""
    End If
    derligneColonne = j - 1
End Function

Les valeurs des grades sont différentes, certaines contiennent un espace à la fin et d'autres pas, exemple: "T" et "T "

Cdlt

Merci beaucoup Arturo !
Ces erreurs étaient effectivement facilement évitable, je manque de sommeil !
Et il y aurait une formule pour que excel ne différencie pas les valeurs des grades avec espaces de ceux sans espaces ?
Plutôt que d'enlever les espaces à chaque fois.

[ARTURO83]

Et il y aurait une formule pour que excel ne différencie pas les valeurs des grades avec espaces de ceux sans espaces ?

Oui, dans le VBA, utilisez Trim pour supprimer tous les espaces, LTrim pour supprimer les espaces à gauche de la valeur et RTrim pour supprimer les espaces à droite de la valeur

exemple dans votre cas: Crtitere=RTrim(Sheets("Criteres").(Cells(i, 1))

Cdlt

[hugo1674]

Oui, dans le VBA, utilisez Trim pour supprimer tous les espaces, LTrim pour supprimer les espaces à gauche de la valeur et RTrim pour supprimer les espaces à droite de la valeur

exemple dans votre cas: Crtitere=RTrim(Sheets("Criteres").(Cells(i, 1))

Cdlt

Ok merci beaucoup, j'ai supprimé les espaces dans la première colonne de la première feuille c'était plus simple donc j'ai utilisé :

Sub TEST6()
Range("A1").EntireColumn = Application.Trim(Range("A1").EntireColumn)

End Sub

R.Trim ne fonctionnait pas avec cette sub, je ne comprends pas pourquoi, si vous avez une explication je suis preneur.

Votre formule empêchait juste de créer les nouvelles feuilles contenant les espaces dans les critères et donc ces données n'apparaissaient pas.

Maintenant je dois exécuter deux macro, il y a t-il un moyen d'inclure cette dernière dans la macro principale pour n'avoir qu'une macro à exécuter ?

[ARTURO83]

R.Trim ne fonctionnait pas avec cette sub, je ne comprends pas pourquoi, si vous avez une explication je suis preneur.

Ce n'est pas R.Trim mais RTrim (pas de point)

Maintenant je dois exécuter deux macro, il y a t-il un moyen d'inclure cette dernière dans la macro principale pour n'avoir qu'une macro à exécuter ?

Sub TEST6()
Range("A1").EntireColumn = Application.Trim(Range("A1").EntireColumn)
End Sub

Oui, Vu qu'il n' y a qu'une seule ligne, copiez cette cligne au début de l'autre macro.