Counting number of times a number will appear in a Pasted column, some cells having multiple numbers in them using VBA

[daltendavis]

For example I would paste in A1:
995
950-993
*995-118
118
790-118

I want it to return on a separate sheet:

995 2
950 1
993 1
118 3
790 1

Right now I have it coming back as exactly what is pasted in the cell and cannot figure it out what so ever.

Thank you for your help.

EDIT:
Also forgot to mention, like the *995 in the example some entries have an astrix in front of them it is split with another store. Thanks again

 

[MickG]

Try this for results on sheet 2.

[COLOR="Navy"]Sub[/COLOR] MG26Jun52
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[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
Dn.Value = IIf(Left(Dn.Value, 1) = "*", Mid(Dn.Value, 2), Dn.Value)
    Sp = Split(Dn.Value, "-")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
            .Item(Sp(n)) = .Item(Sp(n)) + 1
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR]
Sheets("Sheet2").Range("A1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[daltendavis]

It came back as a compiling error: Expected End With

 

[MickG]

Sorry Typo at end of code
Try this:-

[COLOR="Navy"]Sub[/COLOR] MG26Jun28
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[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
Dn.Value = IIf(Left(Dn.Value, 1) = "*", Mid(Dn.Value, 2), Dn.Value)
    Sp = Split(Dn.Value, "-")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
            .Item(Sp(n)) = .Item(Sp(n)) + 1
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR]
Sheets("Sheet2").Range("A1").Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Also try this for your other thread:-
Results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG26Jun30
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[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
Dn.Value = IIf(Left(Dn.Value, 1) = "*", Mid(Dn.Value, 2), Dn.Value)
    Sp = Split(Dn.Value, "-")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
            [COLOR="Navy"]If[/COLOR] Not .exists(Sp(n)) [COLOR="Navy"]Then[/COLOR]
            .Add Sp(n), Array(UBound(Sp) + 1, 1)
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Sp(n))
                    Q(1) = Q(1) + 1
                .Item(Sp(n)) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To .Count * 10, 1 To 2)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
        c = c + 1
        Ray(c, 1) = K
        Ray(c, 2) = Format(Val(.Item(K)(1)) / Val(.Item(K)(0)), "0.00")
    [COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet2").Range("A1").Resize(c, 2) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[daltendavis]

Thank youuuuu both work you are the bomb

 

[daltendavis]

Hey Mick some of the numbers start with a 0 in front of them, for example 043, 014, 015, etc. Would the values returning on sheet 2 be able to have the 0 infront of them as well? this is an example of something I would be pasting while utilizing the second VBA code on this thread:

CLM CHEP
CLM CHEP
703 - 551
925 - 909
OFF
OFF
OFF
975 - 153
705 - 879
1 Pal WC Meats - 849 - 531
461 - 502
597 - 683
OFF
OFF
021 - 099
093 - 386
841 - 048
OFF
118 - 938
102 - 407
167 - 900
657 - 699
OFF
014 - 019
OFF
132 - 073
*022 - 136 - 164
077
508
WEST ROCK
409 - 888
719
933 - 983
395
OFF
015 - 790
049 - 043
829 - 022
850 - 788
058 - 912

Thanks again so much for the help

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG26Jun58
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[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
Dn.Value = IIf(Left(Dn.Value, 1) = "*", Mid(Dn.Value, 2), Dn.Value)
    Sp = Split(Dn.Value, "-")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
            [COLOR="Navy"]If[/COLOR] Not .exists(Sp(n)) [COLOR="Navy"]Then[/COLOR]
                .Add Sp(n), Array(UBound(Sp) + 1, 1)
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Sp(n))
                    Q(1) = Q(1) + 1
                .Item(Sp(n)) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To .Count * 10, 1 To 2) [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
        c = c + 1
        Ray(c, 1) = Trim(K)
        Ray(c, 2) = Format(Val(.Item(K)(1)) / Val(.Item(K)(0)), "0.00")
    [COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet2").Range("A1").Resize(c, 2) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick