Doublons

Pour afficher le résultat à partir de la cellule G1
Tu places ceci à la fin du code avant le msgbox

With Worksheets("Feuil1") 'nom feuille à adapter
'de manière horizontale
.Range("G1").Resize(UBound(Tableau, 1), UBound(Tableau, 2)) = _
Tableau
'De manière verticale
.Range("G1").Resize(UBound(Tableau, 2), UBound(Tableau, 1)) = _
Application.Transpose(Tableau)
End With




"oliver" <oliver6@free.fr> a écrit dans le message de groupe de discussion :
O5f$0iUkJHA.1248@TK2MSFTNGP03.phx.gbl...
Bonsoir,
j'utilise la macro ci-dessous pour dénombrer les doublons. Le résultats est
restitué dans une MsgBox, comment faire pour qu'il apparaisse dans une
feuille de calcul en incrémentant à partir de la cellule A1?
Merci
Sub CompterLesNomsIdentiques()
Dim Cell As Range
Dim Ligne As Integer, I As Integer
Dim M As Byte
Dim U As Boolean
Dim Tableau()
Dim Resultat As String

Ligne = Range("A65536").End(xlUp).Row
M = 1
ReDim Preserve Tableau(2, M)

For Each Cell In Range("B4:B" & Ligne)
U = False
For I = 1 To M
If Cell = Tableau(0, I - 1) Then
Tableau(1, I - 1) = Tableau(1, I - 1) + 1
U = True
End If
Next I

If Tableau(1, M - 1) = "" And U = False Then
Tableau(0, M - 1) = Cell
Tableau(1, M - 1) = 1
M = M + 1
ReDim Preserve Tableau(2, M)
End If
Next Cell

For I = 1 To M - 1
Resultat = Resultat & Tableau(0, I - 1) & Chr(9) & Tableau(1, I - 1) &
Chr(10)
Next I
MsgBox Resultat

End Sub

On 17 fév, 22:43, "oliver" <oliv...@free.fr> wrote:

Bonsoir,
j'utilise la macro ci-dessous pour dénombrer les doublons. Le résulta ts est
restitué dans une MsgBox, comment faire pour qu'il apparaisse dans une
feuille de calcul en incrémentant à partir de la cellule A1?
    Merci
Sub CompterLesNomsIdentiques()
Dim Cell As Range
Dim Ligne As Integer, I As Integer
Dim M As Byte
Dim U As Boolean
Dim Tableau()
Dim Resultat As String

Ligne = Range("A65536").End(xlUp).Row
M = 1
ReDim Preserve Tableau(2, M)

For Each Cell In Range("B4:B" & Ligne)
U = False
For I = 1 To M
If Cell = Tableau(0, I - 1) Then
Tableau(1, I - 1) = Tableau(1, I - 1) + 1
U = True
End If
Next I

If Tableau(1, M - 1) = "" And U = False Then
Tableau(0, M - 1) = Cell
Tableau(1, M - 1) = 1
M = M + 1
ReDim Preserve Tableau(2, M)
End If
Next Cell

For I = 1 To M - 1
Resultat = Resultat & Tableau(0, I - 1) & Chr(9) & Tableau(1, I - 1) &
Chr(10)
Next I
MsgBox Resultat

End Sub

salut
Pourquoi ne pas utiliser directement la commande filtres elaborés ?
Il suffit de faire références à la meme plage de données en zone de
critères et en zone de recherche en cochant la case... doublons
puis d'indiquer une cellule vierge pour recevoir la liste épurée