Supprimer des cellules identiques d'une plage

Bonjour à tous,

Suite à une extraction de caractères de cellules de la colonne A, je cherche à supprimer dans la colonne C (lieu où j'ai reporté les extractions), les cellules contenant les mêmes valeurs pour ensuite les trier.

La colonne B correspond aux résultats attendus.

J'ai essayé ce code mais la DO LOOP semble causer une boucle infinie

Auriez-vous peut être une meilleure idée d'approche du problème?

Sub essaie()

Dim n, i, j As Integer
Dim rg As Range

n = ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To n

    ThisWorkbook.Worksheets(1).Cells(i, 3).Value = Left(ThisWorkbook.Worksheets(1).Cells(i, 1).Value, InStr(ThisWorkbook.Worksheets(1).Cells(i, 1).Value, "*"))

Next i

Set rg = ThisWorkbook.Worksheets(1).Cells(2, 3).Resize(n, 1)

    rg.Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange rg
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For j = 1 To ThisWorkbook.Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row

    Do

        For i = 1 To n

            If ThisWorkbook.Worksheets(1).Cells(i, 3).Value = ThisWorkbook.Worksheets(1).Cells(i + 1, 3).Value Then ThisWorkbook.Worksheets(1).Cells(i + 1, 3).Value = ""

        Next i

        Set rg = ThisWorkbook.Worksheets(1).Cells(2, 3).Resize(n, 1)

        rg.Select
        ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Feuil1").Sort
            .SetRange rg
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

    Loop While ThisWorkbook.Worksheets(1).Cells(j, 3).Value = ThisWorkbook.Worksheets(1).Cells(j + 1, 3).Value

Next j

End Sub

Je pense avoir compris le problème :

Sub essaie()

Application.ScreenUpdating = False

Dim n, i, j As Integer
Dim rg As Range

n = ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To n

    ThisWorkbook.Worksheets(1).Cells(i, 3).Value = Left(ThisWorkbook.Worksheets(1).Cells(i, 1).Value, InStr(ThisWorkbook.Worksheets(1).Cells(i, 1).Value, "*"))

Next i

Set rg = ThisWorkbook.Worksheets(1).Cells(2, 3).Resize(n, 1)

    rg.Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange rg
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For j = 1 To ThisWorkbook.Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row

    Do

        For i = 1 To ThisWorkbook.Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row

            If ThisWorkbook.Worksheets(1).Cells(i, 3).Value = ThisWorkbook.Worksheets(1).Cells(i + 1, 3).Value Then ThisWorkbook.Worksheets(1).Cells(i + 1, 3).Value = ""

        Next i

        Set rg = ThisWorkbook.Worksheets(1).Cells(2, 3).Resize(n, 1)

        rg.Select
        ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Feuil1").Sort
            .SetRange rg
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

    Loop Until ThisWorkbook.Worksheets(1).Cells(ThisWorkbook.Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row + 1, 3).Value = ""

Next j

End Sub

Je sais pas si il y a plus court ou plus simple?

Bonjour,

une proposition qui te met directement le résultat dans B.

J'ai supposé que tous avaient une *.

Sub test()
    Dim Dict, c As Variant, pl() As Variant, gr As String
    Set Dict = CreateObject("Scripting.Dictionary")
    pl = Range("a2", [a65000].End(xlUp)).Value
    For Each c In pl
        gr = Split(c, "*")(0) & "*"
        Dict(gr) = gr
    Next c
    [B2].Resize(Dict.Count, 1) = Application.Transpose(Dict.keys)
End Sub

Eventuellement ajouter le tri.

eric

Excellent!

Merci beaucoup

A mon avis c'est bien mieux avec ce code.

Bonjour,

Pour le tri , si B1 est l'entête

 [B1].Sort Key1:=[B2], Order1:=xlAscending, Header:=xlYes

A mettre en dernière ligne de code avant "End sub"