XL 2019 Chiffre aligner sans doublon

Guismo33 · 24 Janvier 2020

Bonjour a tous.

je recherche une formule sans doublons et qui aligne un certain nombre de chiffres:
dans cette exemple je voudrais q'en I2:T2 il s'affiche ces nombres : 8 13 7 1 11 14 16
car dans la colonne dite en H j'ai plusieurs nombre avec des vides et doublons.
formules Vba ou simplifier, merci à vous

bien à vous

CISCO · 24 Janvier 2020

Bonjour

Cf. une méthode en pièce jointe, avec une formule matricielle à valider avec Ctrl+maj+entrer.

@ plus

Guismo33 · 24 Janvier 2020

CISCO à dit:
Bonjour

Cf. une méthode en pièce jointe, avec une formule matricielle à valider avec Ctrl+maj+entrer.

@ plus

Bonjour CISCO,
je récupére des nombre en colonne et les tries sur lignes, dans ta formule tu et en colonne.
merci a toi

CISCO · 24 Janvier 2020

Bonjour

Cf. en pièce jointe. On peut faire avec quelques $ en moins, mais cela n'est pas très important...

@ plus

job75 · 24 Janvier 2020

Bonjour Guismo33, CISCO,

Une solution VBA pour varier le plaisir :

VB:

Sub Transpose()
Dim P As Range
Application.ScreenUpdating = False
With ActiveSheet 'à adapter
    Set P = .UsedRange.Columns(1).Cells
    With .[C1] 'cellule de destination à adapter
        .Resize(, .Parent.Columns.Count - .Column + 1).ClearContents 'RAZ
        With .Resize(, P.Count)
            .Value = Application.Transpose(P)
            On Error Resume Next 'si aucune SpecialCell
            .SpecialCells(xlCellTypeBlanks).Delete xlToLeft
        End With
    End With
End With
End Sub

A+

job75 · 24 Janvier 2020

La solution précédente peut prendre trop de temps s'il y a beaucoup de cellules vides à supprimer.

Avec ce fichier (2) ce sera toujours très rapide car on utilise des tableaux VBA :

VB:

Sub Transpose()
Dim a, b(), i&, n%
With ActiveSheet 'à adapter
    a = .UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ReDim b(1 To 1, 1 To UBound(a))
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            n = n + 1
            b(1, n) = a(i, 1)
        End If
    Next
    '---restitution---
    With .[C1] 'cellule de destination à adapter
        If n Then .Resize(, n) = b
        .Offset(, n).Resize(, .Parent.Columns.Count - n - .Column + 1).ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

Guismo33 · 24 Janvier 2020

CISCO à dit:
Bonjour

Cf. une méthode en pièce jointe, avec une formule matricielle à valider avec Ctrl+maj+entrer.

@ plus

job75 à dit:

La solution précédente peut prendre trop de temps s'il y a beaucoup de cellules vides à supprimer.

Avec ce fichier (2) ce sera toujours très rapide car on utilise des tableaux VBA :

VB:

Sub Transpose()
Dim a, b(), i&, n%
With ActiveSheet 'à adapter
    a = .UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ReDim b(1 To 1, 1 To UBound(a))
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            n = n + 1
            b(1, n) = a(i, 1)
        End If
    Next
    '---restitution---
    With .[C1] 'cellule de destination à adapter
        If n Then .Resize(, n) = b
        .Offset(, n).Resize(, .Parent.Columns.Count - n - .Column + 1).ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

Re
Merci pour cette macro

job75 à dit:

La solution précédente peut prendre trop de temps s'il y a beaucoup de cellules vides à supprimer.

Avec ce fichier (2) ce sera toujours très rapide car on utilise des tableaux VBA :

VB:

Sub Transpose()
Dim a, b(), i&, n%
With ActiveSheet 'à adapter
    a = .UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ReDim b(1 To 1, 1 To UBound(a))
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            n = n + 1
            b(1, n) = a(i, 1)
        End If
    Next
    '---restitution---
    With .[C1] 'cellule de destination à adapter
        If n Then .Resize(, n) = b
        .Offset(, n).Resize(, .Parent.Columns.Count - n - .Column + 1).ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

Bonjour,
merci pour cette macro Job75, bonne journée.

bien à vous

Guismo33 · 27 Janvier 2020

CISCO à dit:
Bonjour

Cf. en pièce jointe. On peut faire avec quelques $ en moins, mais cela n'est pas très important...

@ plus

Bonjour CISCO

Trés bonne formule mais si il y a un doublons en nombre il ne l’enlève pas?
ex: si il y a 2 fois 47

merci à toi

@plus

job75 · 27 Janvier 2020

Ah oui les doublons alors voyez ce fichier (3) :

VB:

Sub TransposeSansDoublon()
Dim a, d As Object, i&
With ActiveSheet 'à adapter
    a = .UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then d(a(i, 1)) = ""
    Next
    '---restitution---
    With .[C1] 'cellule de destination à adapter
        If d.Count Then .Resize(, d.Count) = d.keys
        .Offset(, d.Count).Resize(, .Parent.Columns.Count - d.Count - .Column + 1).ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub

CISCO · 27 Janvier 2020

Bonsoir à tous, bonsoir Job75, bonsoir Guismo33

J'avais complètement oublié de traiter le cas des doublons (des triplets, quadruplets...). C'est fait dans le fichier ci-dessous, toujours avec une formule matricielle.

@ plus

job75 · 28 Janvier 2020

BonjourGuismo33, CISCO, le forum,

@CISCO ta formule a l'avantage de pouvoir être utilisée sur les versions antéreures à Excel 2007.

Mais Guismo33 étant sur Excel 2019 on peut utiliser SIERREUR, formule matricielle en C5 :

Code:

=SIERREUR(INDEX($A$1:$A$11;PETITE.VALEUR(SI(($A1:$A11<>"")*NON(NB.SI($B5:B5;$A$1:$A$11));LIGNE($A$1:$A$11));1));"")

Bonne journée.

CISCO · 28 Janvier 2020

Bonjour à tous

Bonjour job75. En regardant ta proposition, je me suis demandé pourquoi tu utilises PETITE.VALEUR(....,1) et pas MIN. En testant, j'ai compris. Pratique...

@ plus

patricktoulon · 28 Janvier 2020

bonsoir
sinon avec vba
sans doublons dans l'ordre sans dico ou collection

VB:

Sub test()    'horizontal
    Dim rng As Range, tableau
    Set rng = Range("A1:A11")
    tableau = NoDoubleInOrder(rng)
    [c6].Resize(, UBound(tableau) + 1) = tableau
End Sub
'
Sub test2()    'vertical
    Dim rng As Range, tableau
    Set rng = Range("A1:A11")
    tableau = NoDoubleInOrder(rng)
    [c6].Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
End Sub    '
'
'
Function NoDoubleInOrder(rng)
    Dim original, MyArray(), I&
    original = Application.Transpose(rng.Value)
    ReDim MyArray(1 To Application.Max(rng))
    For I = 1 To UBound(original)
        If original(I) <> "" Then MyArray(Val(original(I))) = original(I)
    Next
    NoDoubleInOrder = Split(Application.Trim(Join(MyArray)), " ")
End Function

Guismo33 · 3 Février 2020

job75 à dit:
BonjourGuismo33, CISCO, le forum,

@CISCO ta formule a l'avantage de pouvoir être utilisée sur les versions antéreures à Excel 2007.

Mais Guismo33 étant sur Excel 2019 on peut utiliser SIERREUR, formule matricielle en C5 :

Code:

=SIERREUR(INDEX($A$1:$A$11;PETITE.VALEUR(SI(($A1:$A11<>"")*NON(NB.SI($B5:B5;$A$1:$A$11));LIGNE($A$1:$A$11));1));"")

Bonne journée.

Bonjour job75,

merci pour cette formule ,elle me conviens bonne journée.

Guismo33 · 3 Février 2020

CISCO à dit:
Bonsoir à tous, bonsoir Job75, bonsoir Guismo33

J'avais complètement oublié de traiter le cas des doublons (des triplets, quadruplets...). C'est fait dans le fichier ci-dessous, toujours avec une formule matricielle.

@ plus

Bonjour CISCO,

merci a toi aussi pour ta recherche avec Job75 trop cool, bonne journée.

XL 2019 Chiffre aligner sans doublon

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency