Sort & count

[jayanthimurali]

Can u please help

I have many names which i need to count manually and input and delete the names and sort the name whihc is highest

For example

arun
shela
robert
arun
rosy
arun
rosy

It should count arun as3 and rosy 2 shela 1 and robert 1,
only one name should apear as arun that is it should not be repetative like above but it should count as 3 and arun should be the first name as it pears 3 names than rosy, than robert and so on.

Please help if i copy the names from other file it should automatically sort as above

Thanks in advance

 

[Sektor]

Data tab -> Remove Duplicates

 

[MickG]

Try this:-
Results column "B".

[COLOR="Navy"]Sub[/COLOR] MG06Jul01
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] i           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] j           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] temp1       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Temp2       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & rows.count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.value, 1
    [COLOR="Navy"]Else[/COLOR]
        .Item(Dn.value) = .Item(Dn.value) + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
 
Ray = Application.Transpose(Array(.keys, .Items))
[COLOR="Navy"]For[/COLOR] i = 1 To UBound(Ray)
    [COLOR="Navy"]For[/COLOR] j = i To UBound(Ray)
        [COLOR="Navy"]If[/COLOR] Ray(j, 2) > Ray(i, 2) [COLOR="Navy"]Then[/COLOR]
            temp1 = Ray(i, 1)
            Temp2 = Ray(i, 2)
                Ray(i, 1) = Ray(j, 1)
                Ray(i, 2) = Ray(j, 2)
                    Ray(j, 1) = temp1
                    Ray(j, 2) = Temp2
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] j
[COLOR="Navy"]Next[/COLOR] i
Range("B1").Resize(.count) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Biz]

There two vba codes to solve the problem.

Sub EasySol()
Dim LR As Long
 LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    Range("A1:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    
End Sub

Sub test()
Dim a, e, b(), n As Long
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
Columns("b").ClearContents
If Not IsArray(a) Then
     Range("b1").Value = a: Exit Sub
End If
ReDim b(1 To UBound(a, 1), 1 To 1)
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For Each e In a
          If Not IsEmpty(e) And Not .exists(e) Then
               n = n + 1: b(n, 1) = e
               .Add e, Nothing
          End If
    Next
End With
Range("b1").Resize(n).Value = b
End Sub

EasySol is much easier for reading and following.

Biz

 

[jayanthimurali]

Thank you very much

Biz I have tried the easysol

I have selected the and General and easysol at the top and input the code but iam getting runtime error 1004

Thanks

 

[Biz]

Not sure why it does not work for you.
I have put comments so you can follow what's happening refer below.

Sub EasySol()
Dim LR As Long
'Defines Last row using Column A
 LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

'Advance copies unique values B1   
 Range("A1:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    
End Sub

Can you please paste your entire code?

Biz

 

[jayanthimurali]

General easysol
Sub easySol()
Dim LR As Long
LR = ActiveSheet.Cells(Rows.Count, "A").End(x1up).Row
Range("A1:A" & LR).AdvancedFilter Action:=x1filtercopy, CopyToRange:=Range("B1"), Unique:=True
End Sub

I have return as u have given me

 

[Biz]

Hi mate,

I think there is typo error have look bold text in both Before and After code.

Before

LR = ActiveSheet.Cells(Rows.Count, "A").End(x[B]1[/B]up).Row

Should be

 LR = ActiveSheet.Cells(Rows.Count, "A").End(x[B]l[/B]Up).Row

My suggestion is to copy and paste the code.

Biz

 

[jayanthimurali]

Sorry Iam getting the smae message

"Run-time error '1004':
Application-defined or object-defined error"

 

[mirabeau]

You've got a "1" instead of "l" in two places, xlUp and xlfiltercopy. Have you changed both?

Also, if you've got more than around 40k rows (albeit unlikely) you may find that advanced filter doesn't always work very well.