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
| Option Explicit
Public Sub Exemple_D_Appel()
Dim Plage As Range, RngResult As Range, DL As Long, x As Integer
Dim T As Single
For x = 6 To 8
'initialise les données dans la feuille
Efface_Tout
Remplissage 200000, x '====> Données à faire évoluer pour voir les résultats
'variables
T = Timer
DL = Range("A" & Rows.Count).End(xlUp).Row
Set Plage = Range("A1:E" & DL) 'Union(Range("A1:A" & DL), Range("C1:C" & DL), Range("E1:E" & DL), Range("G1:H" & DL))
'lance le traitement
Set RngResult = PlageDesDoublons(Plage, "#", True, "J", "K")
'annonce les résultats
Debug.Print Timer - T & " secondes pour x = " & x
Debug.Print RngResult.Areas.Count & " aera " '& RngResult.Address
Next
'test du résultat de la fonction
'RngResult.EntireRow.Select
End Sub
Private Function PlageDesDoublons(PlageATraiter As Range, _
Separateur As String, _
Doublons As Boolean, _
ParamArray ColonnesIntermediaires() As Variant) As Range
Dim c As Range, FormConc As String, Verif As String, n As Long, T, i As Long
Dim p1 As Range, p2 As Range, p3 As Range
Application.ScreenUpdating = False
With PlageATraiter.Parent
'vérifications d'usage des paramètres passés à la fonction
On Error GoTo Rejet
Verif = PlageATraiter.Address
.Columns(ColonnesIntermediaires(0)).ClearContents
.Columns(ColonnesIntermediaires(1)).ClearContents
On Error GoTo 0
If .Columns(ColonnesIntermediaires(0)).Offset(, 1).Address <> .Columns(ColonnesIntermediaires(1)).Address Then
GoTo Eject
End If
'--------------------------------------------
'variables utiles
n = PlageATraiter.Rows.Count
For Each c In PlageATraiter.Columns
FormConc = FormConc & Replace(Split(c.Address, ":")(0), "$", "") & "&" & """" & Separateur & """&"
Next
FormConc = "=" & Left(FormConc, Len(FormConc) - 5)
Set p1 = .Range(ColonnesIntermediaires(0) & "1:" & ColonnesIntermediaires(0) & n)
Set p2 = .Range(ColonnesIntermediaires(1) & "1:" & ColonnesIntermediaires(1) & n)
Set p3 = .Range(ColonnesIntermediaires(0) & "1:" & ColonnesIntermediaires(1) & n)
'--------------------------------------------
'Traitement
On Error GoTo Erreur_Separateur
p1.Formula = FormConc
On Error GoTo 0
p2.Formula = "=ROW()"
p3.Value = p3.Value
p3.Sort key1:=p3, order1:=xlAscending, Header:=xlNo
T = p3
For i = n To 2 Step -1
If T(i, 1) = T(i - 1, 1) Then T(i, 1) = ""
Next
p3.Value = T
p3.Sort key1:=p2, order1:=xlAscending, Header:=xlNo
On Error GoTo PlageVide
If Doublons Then
Set PlageDesDoublons = p1.SpecialCells(xlCellTypeBlanks)
Else
Set PlageDesDoublons = p1.SpecialCells(xlCellTypeConstants)
End If
On Error GoTo 0
.Columns(ColonnesIntermediaires(0)).ClearContents
.Columns(ColonnesIntermediaires(1)).ClearContents
End With
'--------------------------------------------
'Fin
Application.ScreenUpdating = True
Exit Function
'Traitement d'erreur des paramètres
Eject:
Application.ScreenUpdating = True
MsgBox "Les colonnes intermédiaires doivent être contigues", vbCritical
Set PlageDesDoublons = Nothing
Exit Function
Erreur_Separateur:
Application.ScreenUpdating = True
MsgBox "Le séparateur choisi n'est pas valide pour la fonction.", vbCritical
Set PlageDesDoublons = Nothing
Exit Function
Rejet:
MsgBox "L'un des (ou tous les) paramètres est incorrect.", vbCritical
PlageVide:
Application.ScreenUpdating = True
Set PlageDesDoublons = Nothing
'--------------------------------------------
End Function
Private Sub Remplissage(n As Long, x As Integer)
'remplit la feuille
Dim i As Long, k As Long, L() As String
ReDim L(0 To n, 0 To 4)
Randomize Timer
For i = 0 To n
For k = 0 To 4
L(i, k) = Chr(Int((x * Rnd) + 65))
Next
Next
Application.ScreenUpdating = False
Range("A1").Resize(n + 1, 5) = L
'insère colonnes et lignes vides pour tester ==> Inutile
'Columns("B:B").Insert Shift:=xlToRight
'Columns("D:D").Insert Shift:=xlToRight
'Columns("F:F").Insert Shift:=xlToRight
'Rows("14:28").Insert Shift:=xlDown
Application.ScreenUpdating = True
End Sub
Private Sub Efface_Tout()
Cells.Clear
End Sub |
(d'où mon allusion aux ponts, aux violons ...).
Envoyé par RyuAutodidacte
en n'oubliant pas d'indiquer qu'elle est la solution finale choisie 
Partager