Extract selected number and move them into another locations

[motilulla]

Hello,</SPAN></SPAN>

I got lottery results in the cells D6:J1000, and in the cells C6:C1000 I have numbers from 1 to 50.</SPAN></SPAN>

In the area D1:J3 where I want to put the number, which I want to extract, could be any between 1 to 50 and copy past that all rows in the columns M:T the example below is shown with 5 numbers, once these numbers are copy paste in the column M:T I want column "M" number could be colour with alternate colour as shown </SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1				1	7	8	10	12
2
3
4
5			Numbers	n1	n2	n3	n4	n5	*1	*2			Numbers	n1	n2	n3	n4	n5	*1	*2
6			1	36	10	6	39	31	6	10			1	36	10	6	39	31	6	10
7			2	35	33	26	40	5	3	8			1	2	10	30	44	1	1	8
8			1	2	10	30	44	1	1	8			1	36	21	10	6	9	6	2
9			4	43	38	19	10	46	1	11			1	43	8	49	6	26	10	6
10			5	2	30	38	43	46	7	2			1	9	1	5	22	38	10	2
11			8	27	10	30	47	12	9	8			1	13	32	37	14	48	1	7
12			10	15	40	24	48	38	2	9			1	27	14	44	15	11	7	2
13			12	29	32	23	1	5	1	7			1	13	50	42	39	34	11	9
14			1	36	21	10	6	9	6	2			1	32	35	17	49	5	5	1
15			7	46	32	27	3	41	4	8			1	26	3	41	33	7	2	10
16			7	9	6	13	28	37	4	5			7	46	32	27	3	41	4	8
17			7	31	49	28	20	3	5	2			7	9	6	13	28	37	4	5
18			5	3	22	50	10	37	6	10			7	31	49	28	20	3	5	2
19			5	32	13	14	39	30	3	9			7	2	11	14	13	21	1	8
20			5	42	32	23	25	37	11	1			7	24	37	19	28	36	6	3
21			9	13	50	5	33	15	9	11			7	26	45	24	7	37	9	5
22			8	37	7	28	13	4	11	10			8	27	10	30	47	12	9	8
23			5	9	23	40	16	14	1	5			8	37	7	28	13	4	11	10
24			4	9	14	23	8	1	7	1			8	11	50	13	40	2	10	1
25			3	26	43	1	21	40	9	6			8	19	43	44	12	45	10	5
26			2	7	10	5	44	34	10	2			10	15	40	24	48	38	2	9
27			2	14	49	21	19	24	5	11			10	38	29	10	48	1	4	3
28			2	15	49	12	26	42	5	8			12	29	32	23	1	5	1	7
29			2	43	36	12	42	19	8	5			12	6	30	26	48	12	6	7
30			2	4	25	19	36	1	3	11			12	12	18	8	44	33	8	4
31			2	23	25	2	49	16	6	9
32			2	3	19	40	9	5	5	2
33			1	43	8	49	6	26	10	6
34			1	9	1	5	22	38	10	2
35			1	13	32	37	14	48	1	7
36			1	27	14	44	15	11	7	2
37			16	32	43	26	34	17	2	10
38			16	10	42	17	32	31	2	5
39			16	4	25	28	5	43	6	11
40			18	23	34	8	24	38	3	7
41			18	45	48	40	34	32	10	1
42			18	40	2	26	27	49	10	5
43			20	31	28	42	15	7	10	11
44			21	32	27	39	36	15	3	10
45			20	41	9	30	14	45	4	9
46			21	37	17	34	16	23	9	6
47			9	46	27	13	43	25	4	8
48			12	6	30	26	48	12	6	7
49			15	7	31	39	23	33	6	10
50			18	26	49	19	45	35	2	5
51			21	21	35	42	14	43	7	9
52			1	13	50	42	39	34	11	9
53			2	43	1	18	27	7	8	4
54			1	32	35	17	49	5	5	1
55			4	11	19	39	28	27	3	10
56			5	43	37	32	26	49	5	4
57			8	11	50	13	40	2	10	1
58			10	38	29	10	48	1	4	3
59			12	12	18	8	44	33	8	4
60			1	26	3	41	33	7	2	10
61			7	2	11	14	13	21	1	8
62			7	24	37	19	28	36	6	3
63			7	26	45	24	7	37	9	5
64			5	13	49	10	45	3	11	2
65			5	40	26	50	1	21	4	2
66			5	27	46	38	2	8	2	6
67			9	19	16	24	37	35	2	7
68			8	19	43	44	12	45	10	5
69			5	15	50	36	2	28	11	2
70			4	34	37	46	26	2	4	8
71			3	22	6	5	25	34	7	5
72			2	2	31	45	37	23	8	4
73			2	48	9	30	28	1	7	8
74			2	29	42	13	16	35	6	8
75			2	50	40	16	32	8	2	11
76			2	45	12	34	24	30	7	10
77			2	28	4	11	17	15	1	3
Sheet1

Thank you all</SPAN></SPAN>

Excel 2000</SPAN></SPAN>
Regards,</SPAN>
Moti</SPAN></SPAN>

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG18Jul51
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
Ray = Cells(5, 3).CurrentRegion
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        ReDim nray(1 To 7, 1 To 1)
            [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                nray(Ac - 1, 1) = Ray(n, Ac)
            [COLOR="Navy"]Next[/COLOR] Ac
            Dic.Add Ray(n, 1), nray
        [COLOR="Navy"]Else[/COLOR]
          Q = Dic(Ray(n, 1))
          ReDim Preserve Q(1 To 7, 1 To UBound(Q, 2) + 1)
            [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                Q(Ac - 1, UBound(Q, 2)) = Ray(n, Ac)
            [COLOR="Navy"]Next[/COLOR] Ac
           Dic(Ray(n, 1)) = Q
            
        [COLOR="Navy"]End[/COLOR] If
   
[COLOR="Navy"]Next[/COLOR] n

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
c = 6: col = 38

[COLOR="Navy"]Set[/COLOR] Rng = Range("D1:J3")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        col = IIf(col = 6, 38, 6)
        Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)) = Dn.Value
        Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)).Interior.ColorIndex = col
        Cells(c, "N").Resize(UBound(Dic(Dn.Value), 2), 7) = Application.Transpose(Dic(Dn.Value))
        c = c + UBound(Dic(Dn.Value), 2)
    [COLOR="Navy"]End[/COLOR] If

[COLOR="Navy"]Next[/COLOR] Dn

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

Regards Mick

 

[motilulla]

Try this:-

[COLOR=navy]Sub[/COLOR] MG18Jul51
[COLOR=navy]Dim[/COLOR] Ray [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant, Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
Ray = Cells(5, 3).CurrentRegion
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR=navy]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR=navy]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR=navy]Then[/COLOR]
        ReDim nray(1 To 7, 1 To 1)
            [COLOR=navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                nray(Ac - 1, 1) = Ray(n, Ac)
            [COLOR=navy]Next[/COLOR] Ac
            Dic.Add Ray(n, 1), nray
        [COLOR=navy]Else[/COLOR]
          Q = Dic(Ray(n, 1))
          ReDim Preserve Q(1 To 7, 1 To UBound(Q, 2) + 1)
            [COLOR=navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                Q(Ac - 1, UBound(Q, 2)) = Ray(n, Ac)
            [COLOR=navy]Next[/COLOR] Ac
           Dic(Ray(n, 1)) = Q
            
        [COLOR=navy]End[/COLOR] If
   
[COLOR=navy]Next[/COLOR] n

[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] col [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
c = 6: col = 38

[COLOR=navy]Set[/COLOR] Rng = Range("D1:J3")
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        col = IIf(col = 6, 38, 6)
        Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)) = Dn.Value
        Cells(c, "M").Resize(UBound(Dic(Dn.Value), 2)).Interior.ColorIndex = col
        Cells(c, "N").Resize(UBound(Dic(Dn.Value), 2), 7) = Application.Transpose(Dic(Dn.Value))
        c = c + UBound(Dic(Dn.Value), 2)
    [COLOR=navy]End[/COLOR] If

[COLOR=navy]Next[/COLOR] Dn

[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

Wow Mick, the macro result at a glance, result stored as request.</SPAN></SPAN>

I appreciate a lot so kind of your help and time to solve this request. </SPAN></SPAN>

Kind Regards,</SPAN>
Moti </SPAN></SPAN>

 

[MickG]

You're welcome

 

[footoo]

If the number of entries in D1:J3 might be fewer than the entries when the macro was previously run, need to add code that first clears the data in M:T and the fill colors in column M.