Split and group values in excel-CodePudding

Hi I have a column of values which has different suffix after a dot, i need it to group it based on the value after dot. Example i need to split all values that end with .pdf into one column, values with.xls as another column, etc,,,

how to do this is my doubt.

CodePudding user response：

variant using scripting.dictionary:

Sub test()

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    
    Dim cl As Range
    
    For Each cl In [A1:A6]
        If Not dic.exists(Split(cl.Value, ".")(1)) Then
            dic.Add Split(cl.Value, ".")(1), cl.Value
        Else
            dic(Split(cl.Value, ".")(1)) = dic(Split(cl.Value, ".")(1)) & "|" & cl.Value
        End If
    Next cl
    
    Dim x%, i%, dKey, sVal
    
    x = 3
    For Each dKey In dic
        i = 1
        For Each sVal In Split(dic(dKey), "|")
            Cells(i, x).Value = sVal
            i = i   1
        Next sVal
        x = x   1
    Next dKey
        
End Sub

demo:

CodePudding user response：

Split and Group

If you have Microsoft 365, you can use the following:

=LET(FileNames,A1:A6,
    FileExtensions,TEXTAFTER(FileNames,"."),
    UniqueFileExtensions,UNIQUE(FileExtensions),
IFERROR(DROP(REDUCE("",UniqueFileExtensions,
    LAMBDA(CurrentResult,UniqueFileExtension,
    HSTACK(CurrentResult,FILTER(FileNames,FileExtensions=UniqueFileExtension)))),,1),""))

If you want to add the headers, add TOROW and VSTACK:

=LET(FileNames,A1:A6,
    FileExtensions,TEXTAFTER(FileNames,"."),
    UniqueFileExtensions,TOROW(UNIQUE(FileExtensions)),
VSTACK(UniqueFileExtensions,IFERROR(DROP(REDUCE("",UniqueFileExtensions,
    LAMBDA(CurrentResult,UniqueFileExtension,
    HSTACK(CurrentResult,FILTER(FileNames,FileExtensions=UniqueFileExtension)))),,1),"")))

Edit

As suggested by Mayukh Bhattacharya, simplified with TEXTAFTER.
Removed the redundant TOROW from the first formula.

CodePudding user response：

you can use nested dictionaries

Sub test()

    With New Scripting.Dictionary
        Dim cel As Range
            For Each cel In Range("A1").CurrentRegion
                If Not .Exists(Split(cel.Value, ".")(1)) Then .Add Split(cel.Value, ".")(1), New Scripting.Dictionary
                .Item(Split(cel.Value, ".")(1)).Add cel.Value, 1
            Next
        
            Dim iK As Long
                For iK = 0 To .Count - 1
                    Range("C1").Offset(, iK).Resize(.Items(iK).Count).Value = Application.Transpose(.Items(iK).Keys)
                Next
    End With
    
End Sub

just add reference to "Microsoft Scripting Runtime" library