XL 2019 Chiffre aligner sans doublon

Guismo33

XLDnaute Occasionnel
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
 

Pièces jointes

  • fonction.JPG
    fonction.JPG
    20.2 KB · Affichages: 18

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • VBA Classeur(1).xlsm
    19.4 KB · Affichages: 5

job75

XLDnaute Barbatruc
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
 

Pièces jointes

  • VBA Classeur(2).xlsm
    19.9 KB · Affichages: 8

Guismo33

XLDnaute Occasionnel
Bonjour

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

@ plus
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
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
 

Pièces jointes

  • Classeur3 (3).xlsx
    11.3 KB · Affichages: 6

job75

XLDnaute Barbatruc
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
 

Pièces jointes

  • VBA Classeur(3).xlsm
    20.6 KB · Affichages: 3

CISCO

XLDnaute Barbatruc
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
 

Pièces jointes

  • Classeur3 (3).xlsx
    10.6 KB · Affichages: 10

job75

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Classeur3 (4).xlsx
    11 KB · Affichages: 9

patricktoulon

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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.
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées