Divide numbers into unique sorted digits displayed in a label on a userform

问题

I want to divide numbers into unique sorted digits. For example, the number can be 127425 and I would like 12457 as the result, meaning sorted and duplicate removed. I think the best is to explain with example:

+---------+--------+
| Number  | Result |
+---------+--------+
| 127425  | 12457  |
+---------+--------+
| 2784425 | 24578  |
+---------+--------+
| 121     | 12     |
+---------+--------+
| 22222   | 2      |
+---------+--------+
| 9271    | 1279   |
+---------+--------+

The longest result can be only 123456789.

I don't think we need an array for that (no delimiter), but the use of substring could probably do the job. I just don't know where to begin, hence no code.

Any ideas are welcome. Thanks.

回答1:

Try the next function, please:

Function RemoveDuplSort(x As String) As String
  Dim i As Long, j As Long, arr As Variant, temp As String
  'Dim dict As New Scripting.Dictionary 'in case of reference to 'Microsoft Scripting Runtime,
                                        'un-comment this line and comment the next one:
  Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To Len(x)
    dict(Mid(x, i, 1)) = 1
  Next i
  arr = dict.Keys
      For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
  RemoveDuplSort = Join(arr, "")
End Function

It can be called in this way:

Sub testRemoveDuplSort()
  Dim x As String
  x = "2784425" 'x = myLabel.Caption
  Debug.Print RemoveDuplSort(x)
End Sub

回答2:

Alternative to the newer dynamic array functions

Loving the above nice solutions it's always a challenge to think over additional approaches (via Byte array, Filter() and FilterXML() function):

Function UniqueDigits(ByVal txt) As String
    Dim by() As Byte: by = txt
    Dim digits: digits = Array(49, 50, 51, 52, 53, 54, 55, 56, 57, 48, 0) ' equalling Asc values
'a) create 1-based 1-dim array with digit positions
    Dim tmp: tmp = Filter(Application.Match(by, digits, 0), 11, False)
'b) get uniques
    tmp = Uniques(tmp)
'c) sort it (don't execute before getting uniques)
    BubbleSort tmp
'd) return function result
    UniqueDigits = Join(tmp, "")
End Function

Function Uniques(arr)
'Note: using FilterXML() available since vers. 2013+
    Dim content As String       ' replacing "10" referring to zero indexed as 10th digit
    content = Replace("<t><s>" & Join(arr, "</s><s>") & "</s></t>", "10", "0")
    arr = WorksheetFunction.FilterXML(content, "//s[not(preceding::*=.)]")
    Uniques = Application.Transpose(arr)
End Function

Sub BubbleSort(arr)
    Dim cnt As Long, nxt As Long, temp
    For cnt = LBound(arr) To UBound(arr) - 1
        For nxt = cnt + 1 To UBound(arr)
            If arr(cnt) > arr(nxt) Then
                temp = arr(cnt)
                arr(cnt) = arr(nxt)
                arr(nxt) = temp
            End If
        Next nxt
    Next cnt
End Sub

Further hints :-) tl;dr

...explaining

a) how to transform a string to a digits array, b) how to get uniques via FilterXML instead of a dictionary c) (executing BubbleSort needs no further explanation).

ad a) the tricky way to get a pure digits array Transforming a string of digits into an array of single characters may need some explanation.

A string (here txt) can assigned easily to a byte array via Dim by() As Byte: by = txt. (Note that classical characters would be represented in a byte array by a pair of Asc values, where the second value mostly is 0; so digit 1 is represented by 49 and 0, 2 by 50 and 0 up to 9 by 57 and 0).

Digits are defined in a 1-based Asc value array from 1~>49 to 9~>57, followed by the 10th item 0~>48 and eventually the Asc value 0 as 11th item related to each second byte pair.

Dim digits: digits = Array(49, 50, 51, 52, 53, 54, 55, 56, 57, 48, 0) ' equalling Asc values

Usually the Match() function searches for a specified item in order to get its relative position within an array (here digits) and would be executed by the following syntax: ``.

MATCH(lookup_value, lookup_array, [match_type]) where the lookup_value argument can be a value (number, text, or logical value) or a cell reference to a number, text, or logical value.

An undocumented feature is that instead searching e.g. 2 in the lookup_array digits via Application.Match(2, digits,0) you can use the byte array as first argument serving as 1-based array pattern where VBA replaces the current Asc values by their position found within the digits array.

Application.Match(by, digits, 0)

Finally a negative filtering removes the companion Asc 0 values (11 plus argument False) via

Dim tmp: tmp = Filter(Application.Match(by, digits, 0), 11, False)

ad b) get uniques via FilterXML

Help reference for the WorksheetFunction.FilterXML method demands two string parameters

FilterXML(XMLContentString, XPathQueryString)

The first argument doesn't reference a file, but needs a valid ("wellformed") XML text string starting with a root node (DocumentElement) which is roughly comparable to a html structure starting with the enclosing pair of <html>...</html> tags.

So a wellformed content string representing e.g. number 121 could be:

<t>
    <s>1</s>
    <s>2</s>
    <s>1</s>
</t>

The second argument (limited to 1024 characters) must be a valid XPath query string like the following find non-duplicates

"//s[not(preceding::*=.)]"

where the double slash // allows to find s nodes at any hierarchy level and under the condition that it is not preceded by any nodes * with the same value content =.

Recommended readings

@RonRosenfeld is a pioneer author of numerous answers covering the FilterXML method, such as e.g. Split string cell....

@JvDV wrote a nearly encyclopaedic overview at Extract substrings from string using FilterXML.

回答3:

Another VBA routine to sort the unique elements of a cell, using an ArrayList:

Option Explicit
Function sortUniqueCellContents(S As String) As String
    Dim arr As Object, I As Long, ch As String * 1
    
Set arr = CreateObject("System.Collections.ArrayList")

For I = 1 To Len(S)
    ch = Mid(S, I)
    If Not arr.contains(ch) Then arr.Add ch
Next I

arr.Sort
sortUniqueCellContents = Join(arr.toarray, "")

End Function

回答4:

If you have a version of Excel that supports Dynaaic Arrays, then try this (for input in A2)

=CONCAT(SORT(UNIQUE(MID(A2,SEQUENCE(LEN(A2),1,1,1),1))))

How it works

SEQUENCE(LEN(A27),1,1,1) returns an array of numbers 1 .. the length of the input string
MID(A2, ... ,1)) uses that array to return a Spill range of the individual characters in the input string
UNIQUE( reduces that to a range of unique characters only
SORT sorts that range
CONCAT concatenates that range into a single string

Gearing off that to build a VBA function

Function UniqueDigits(s As String) As String
    With Application.WorksheetFunction
        UniqueDigits = Join(.Sort(.Unique(Split(Left$(StrConv(s, 64), Len(s) * 2 - 1), Chr(0)), 1), , , 1), "")
    End With
End Function

回答5:

If your number is in cell A3, then this one will return a string of unique numbers.
=CONCAT(SORT(UNIQUE(MID(A3,ROW(INDIRECT("1:"&LEN(A3))),1))))

来源：https://stackoverflow.com/questions/63540928/divide-numbers-into-unique-sorted-digits-displayed-in-a-label-on-a-userform

标签

excel

vba

sorting

duplicates