Unique to clipboard

[100Conrad]

I did find a most beautiful macro somewhere in the net making it possible for me to just make a selection and
it would make the unique values in the selection go to the clipboard sorted
It worked fine in Excel 2010 but stopped working in Excel 2014.
I get no sensible output , just ￿￿
Could someone please help me adjust it to Excel 2014?
It´s a most useful macro, could be of value for many I believe

Sub Unika_till_clipboard()
Dim no_dupes_coll As New Collection
Dim i As Long
Dim MyArray()
Dim iRow As Integer
Dim szTmp As String
Dim MyDataObj As New DataObject
Dim Cell
Dim j
Dim Swap1
Dim Swap2
Dim iCol

'Gör alla celler till text
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 2), TrailingMinusNumbers:=True

' Selection.SpecialCells(xlCellTypeVisible).Select
' For Each c In Selection.Cells


'Lägga till unika värden i collection
Selection.SpecialCells(xlCellTypeVisible).Select
For Each Cell In Selection.Cells


'For Each cell In Selection
'attempting to add a duplicate key causes an error, so ignore
'and the duplicate will not be added
On Error Resume Next
no_dupes_coll.Add Item:=Cell.Value, key:=Cell.Value
On Error GoTo 0
Next Cell

'Sort the collection (optional)
For i = 1 To no_dupes_coll.Count - 1
For j = i + 1 To no_dupes_coll.Count
If no_dupes_coll(i) > no_dupes_coll(j) Then
Swap1 = no_dupes_coll(i)
Swap2 = no_dupes_coll(j)
no_dupes_coll.Add Swap1, before:=j
no_dupes_coll.Add Swap2, before:=i
no_dupes_coll.Remove i + 1
no_dupes_coll.Remove j + 1
End If
Next j
Next i

'Collection to myArray
If no_dupes_coll.Count > 0 Then
ReDim MyArray(1 To no_dupes_coll.Count)
For i = 1 To no_dupes_coll.Count
MyArray(i) = no_dupes_coll(i)
'Debug.Print MyArray(i)
'delete above line and do your processing here
'Cells(2, 5).Value = myArray(i)
Next i
End If

'Sätta värden i clipboard
For iRow = 1 To no_dupes_coll.Count
For iCol = 1 To 1
szTmp = szTmp & CStr(iCol) & vbTab
Next iCol
szTmp = szTmp & CStr(MyArray(iRow)) & vbCrLf
Next iRow

MyDataObj.SetText szTmp
MyDataObj.PutInClipboard

'clear the collection
Do While no_dupes_coll.Count > 0
no_dupes_coll.Remove 1
Loop

End Sub

 

[Akuini]

I did find a most beautiful macro somewhere in the net making it possible for me to just make a selection and
it would make the unique values in the selection go to the clipboard sorted
It worked fine in Excel 2010 but stopped working in Excel 2014.
I get no sensible output , just ￿￿
Could someone please help me adjust it to Excel 2014?
It´s a most useful macro, could be of value for many I believe

You may try this:

[B][color=Royalblue]Sub[/color][/B] a1076452c()
[i][color=seagreen]'https://www.mrexcel.com/forum/excel-questions/1076452-unique-clipboard.html[/color][/i]
[B][color=Royalblue]Dim[/color][/B] MyDataObj [B][color=Royalblue]As[/color][/B] [B][color=Royalblue]New[/color][/B] DataObject
[B][color=Royalblue]Dim[/color][/B]  scA [B][color=Royalblue]As[/color][/B]  [B][color=Royalblue]Object[/color][/B], scB  [B][color=Royalblue]As[/color][/B]  [B][color=Royalblue]Object[/color][/B], scC  [B][color=Royalblue]As[/color][/B]  [B][color=Royalblue]Object[/color][/B], scD  [B][color=Royalblue]As[/color][/B]  [B][color=Royalblue]Object[/color][/B]
[B][color=Royalblue]Dim[/color][/B] va, x

[B][color=Royalblue]If[/color][/B] Selection.Cells.count = [color=crimson]1[/color] [B][color=Royalblue]Then[/color][/B]
    MsgBox [color=brown]"You must select more than 1 cell"[/color]
    [B][color=Royalblue]Exit[/color][/B] [B][color=Royalblue]Sub[/color][/B]
[B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]

va = Selection.Value
[B][color=Royalblue]Set[/color][/B] scA = CreateObject([color=brown]"System.Collections.ArrayList"[/color])
[B][color=Royalblue]Set[/color][/B] scB = CreateObject([color=brown]"System.Collections.ArrayList"[/color])
[B][color=Royalblue]Set[/color][/B] scC = CreateObject([color=brown]"System.Collections.ArrayList"[/color])
[B][color=Royalblue]Set[/color][/B] scD = CreateObject([color=brown]"System.Collections.ArrayList"[/color])

    [B][color=Royalblue]For[/color][/B] [B][color=Royalblue]Each[/color][/B] x [B][color=Royalblue]In[/color][/B] va
        [B][color=Royalblue]If[/color][/B] x <> [color=brown]""[/color] [B][color=Royalblue]Then[/color][/B]
            [B][color=Royalblue]If[/color][/B] IsNumeric(x) [B][color=Royalblue]Then[/color][/B]
                 [B][color=Royalblue]If[/color][/B] [B][color=Royalblue]Not[/color][/B]  scA.contains(x) [B][color=Royalblue]Then[/color][/B]
                    scA.Add [B][color=Royalblue]CDbl[/color][/B](x)
                [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
            [B][color=Royalblue]ElseIf[/color][/B] IsDate(x) [B][color=Royalblue]Then[/color][/B]
                 [B][color=Royalblue]If[/color][/B] [B][color=Royalblue]Not[/color][/B]  scB.contains(x) [B][color=Royalblue]Then[/color][/B]
                    scB.Add x
                [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
            [B][color=Royalblue]Else[/color][/B]
                 [B][color=Royalblue]If[/color][/B] [B][color=Royalblue]Not[/color][/B]  scC.contains(x) [B][color=Royalblue]Then[/color][/B]
                    scC.Add [B][color=Royalblue]CStr[/color][/B](x)
                [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
            [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
        [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
    [B][color=Royalblue]Next[/color][/B]

[B][color=Royalblue]If[/color][/B]  scA.count > [color=crimson]0[/color]  [B][color=Royalblue]Then[/color][/B] scA.Sort: scD.Addrange scA
[B][color=Royalblue]If[/color][/B]  scB.count > [color=crimson]0[/color]  [B][color=Royalblue]Then[/color][/B] scB.Sort: scD.Addrange scB
[B][color=Royalblue]If[/color][/B]  scC.count > [color=crimson]0[/color]  [B][color=Royalblue]Then[/color][/B] scC.Sort: scD.Addrange scC

        [B][color=Royalblue]For[/color][/B] [B][color=Royalblue]Each[/color][/B] x [B][color=Royalblue]In[/color][/B] scD
            [B][color=Royalblue]If[/color][/B] txt = [color=brown]""[/color] [B][color=Royalblue]Then[/color][/B]
                txt = x
                [B][color=Royalblue]Else[/color][/B]
                txt = txt & vbCrLf & x
            [B][color=Royalblue]End[/color][/B] [B][color=Royalblue]If[/color][/B]
        [B][color=Royalblue]Next[/color][/B]

MyDataObj.SetText txt
MyDataObj.PutInClipboard

[B][color=Royalblue]End[/color][/B] [B][color=Royalblue]Sub[/color][/B]

Example:
Select data in col A > run the macro > paste in col C

Excel 2007 32 bit
[Table="width:, class:head"][tr=bgcolor:#008B8B][th] [/th][th]

A​

[/th][th]

B​

[/th][th]

C​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

1​

[/td][td]Anton[/td][td][/td][td]

1​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

2​

[/td][td]Briar[/td][td][/td][td]

2​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

3​

[/td][td]Jaydon[/td][td][/td][td]

15​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

4​

[/td][td]

04-Mei​

[/td][td][/td][td]

60000​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

5​

[/td][td]

2​

[/td][td][/td][td]

17/01/2018​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

6​

[/td][td]Briar[/td][td][/td][td]

04/05/2018​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

7​

[/td][td]

15​

[/td][td][/td][td]

03/09/2018​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

8​

[/td][td][/td][td][/td][td]Anton[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

9​

[/td][td]Anton[/td][td][/td][td]Briar[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

10​

[/td][td]Anton[/td][td][/td][td]Jaydon[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

11​

[/td][td]

60000​

[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

12​

[/td][td]

1​

[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

13​

[/td][td]

04-Mei​

[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

14​

[/td][td]

03-Sep​

[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#008B8B]

15​

[/td][td]

17-Jan​

[/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet8[/td][/tr][/table]

 

[100Conrad]

Many thanks Akuini, I´m very grateful for being able to use the macro again.

Unfortunately I got a runtime error 2146232576.
Seems like you must have net framework activated

u can solve this by activating net framework 2 and 3.5 from >control panel >turn Windows features on or off > click on netframework3.5(includes 2 and 3) >ok.. it instals and activates netframework2

https://answers.microsoft.com/en-us...tomation/395746f3-9360-4dac-85b8-3311f91290a0

Many thanks again
100Conrad

 

[Akuini]

Many thanks Akuini, I´m very grateful for being able to use the macro again.

Unfortunately I got a runtime error 2146232576.
Seems like you must have net framework activated

u can solve this by activating net framework 2 and 3.5 from >control panel >turn Windows features on or off > click on netframework3.5(includes 2 and 3) >ok.. it instals and activates netframework2

https://answers.microsoft.com/en-us...tomation/395746f3-9360-4dac-85b8-3311f91290a0

Many thanks again
100Conrad

Hm, I just realized "System.Collections.ArrayList" needs net framework installed.
Sorry, don't know how to do the sort part without it.
Maybe someone else here could help.

Just couriuos, why don't you just install the net framework?

 

[ZVI]

I did find a most beautiful macro somewhere in the net making it possible for me to just make a selection and
it would make the unique values in the selection go to the clipboard sorted
It worked fine in Excel 2010 but stopped working in Excel 2014.

Do you mean Excel 2014 for MAC?
Try this code:

Sub SortedUniqOfSelection_ToTheClipboard()
'ZVI:2018-11-11 Code puts sorted & unique values of the selected range to the Clipboard
 
  Dim Rng As Range
  Dim Arr
  Dim MyDataObj As New DataObject
 
  MyDataObj.Clear
  Set Rng = Intersect(Selection, Selection.Worksheet.UsedRange)
  If Rng Is Nothing Then MsgBox "No data": Exit Sub
  Arr = NoDups(Rng)
  If LBound(Arr) = 0 Then MsgBox "No data": Exit Sub
 
  MyDataObj.SetText Join(Arr, vbLf)
  MyDataObj.PutInClipboard
 
End Sub
 
Function NoDups(Rng As Range)
'ZVI:2018-11-11 https://www.mrexcel.com/forum/excel-questions/1076452-unique-clipboard.html
'Returns 1D-array with sorted unique values of the Rng
  Dim Col As New Collection
  Dim Arr(), i As Long, s As String, v, x
  Arr() = Intersect(Rng.Worksheet.UsedRange, Rng).Value
  On Error Resume Next
  With Col
    For Each x In Arr()
      s = Trim(x)
      If Len(s) > 0 Then
        If IsEmpty(Col.Item(s)) Then
          i = 1
          For Each v In Col
            If s < v Then Exit For
            i = i + 1
          Next
          If i > .Count Then .Add s, s Else .Add s, s, Before:=i
        End If
      End If
    Next
    If .Count > 0 Then ReDim Arr(1 To .Count) Else ReDim Arr(0 To 0)
  End With
  i = 0
  For Each x In Col
    i = i + 1
    Arr(i) = x
  Next
  NoDups = Arr()
End Function

Regards