Extract desire groups copy and paste them into another locations

[motilulla]

Hello,</SPAN></SPAN>

Sheet1 I got lottery results in the cells D6:J3500, cells C6:C3500 I have assigned the numbers 1 to 356 each group has 9 rows rest of the rows are empty at movement.</SPAN></SPAN>

In the area D1:J3 where I want to put the group number, which I want to extract it, can be 1 to 21 and copy past that groups in the columns M:T as shown example in the below this would be in the same "Sheet1", also if possible may I request one more VBA that can copy paste groups in to "Sheet2" in the columns C:J please. </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	4	7
2
3
4
5			Gr	n1	n2	n3	n4	n5	*1	*2			Gr	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			1	35	33	26	40	5	3	8			1	35	33	26	40	5	3	8
8			1	2	10	30	44	1	1	8			1	2	10	30	44	1	1	8
9			1	43	38	19	10	46	1	11			1	43	38	19	10	46	1	11
10			1	2	30	38	43	46	7	2			1	2	30	38	43	46	7	2
11			1	27	10	30	47	12	9	8			1	27	10	30	47	12	9	8
12			1	15	40	24	48	38	2	9			1	15	40	24	48	38	2	9
13			1	29	32	23	1	5	1	7			1	29	32	23	1	5	1	7
14			1	36	21	10	6	9	6	2			1	36	21	10	6	9	6	2
15			2	46	32	27	3	41	4	8			4	43	8	49	6	26	10	6
16			2	9	6	13	28	37	4	5			4	9	1	5	22	38	10	2
17			2	31	49	28	20	3	5	2			4	13	32	37	14	48	1	7
18			2	3	22	50	10	37	6	10			4	27	14	44	15	11	7	2
19			2	32	13	14	39	30	3	9			4	32	43	26	34	17	2	10
20			2	42	32	23	25	37	11	1			4	10	42	17	32	31	2	5
21			2	13	50	5	33	15	9	11			4	4	25	28	5	43	6	11
22			2	37	7	28	13	4	11	10			4	23	34	8	24	38	3	7
23			2	9	23	40	16	14	1	5			4	45	48	40	34	32	10	1
24			3	9	14	23	8	1	7	1			7	26	3	41	33	7	2	10
25			3	26	43	1	21	40	9	6			7	2	11	14	13	21	1	8
26			3	7	10	5	44	34	10	2			7	24	37	19	28	36	6	3
27			3	14	49	21	19	24	5	11			7	26	45	24	7	37	9	5
28			3	15	49	12	26	42	5	8			7	13	49	10	45	3	11	2
29			3	43	36	12	42	19	8	5			7	40	26	50	1	21	4	2
30			3	4	25	19	36	1	3	11			7	27	46	38	2	8	2	6
31			3	23	25	2	49	16	6	9			7	19	16	24	37	35	2	7
32			3	3	19	40	9	5	5	2			7	19	43	44	12	45	10	5
33			4	43	8	49	6	26	10	6
34			4	9	1	5	22	38	10	2
35			4	13	32	37	14	48	1	7
36			4	27	14	44	15	11	7	2
37			4	32	43	26	34	17	2	10
38			4	10	42	17	32	31	2	5
39			4	4	25	28	5	43	6	11
40			4	23	34	8	24	38	3	7
41			4	45	48	40	34	32	10	1
42			5	40	2	26	27	49	10	5
43			5	31	28	42	15	7	10	11
44			5	32	27	39	36	15	3	10
45			5	41	9	30	14	45	4	9
46			5	37	17	34	16	23	9	6
47			5	46	27	13	43	25	4	8
48			5	6	30	26	48	12	6	7
49			5	7	31	39	23	33	6	10
50			5	26	49	19	45	35	2	5
51			6	21	35	42	14	43	7	9
52			6	13	50	42	39	34	11	9
53			6	43	1	18	27	7	8	4
54			6	32	35	17	49	5	5	1
55			6	11	19	39	28	27	3	10
56			6	43	37	32	26	49	5	4
57			6	11	50	13	40	2	10	1
58			6	38	29	10	48	1	4	3
59			6	12	18	8	44	33	8	4
60			7	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			7	13	49	10	45	3	11	2
65			7	40	26	50	1	21	4	2
66			7	27	46	38	2	8	2	6
67			7	19	16	24	37	35	2	7
68			7	19	43	44	12	45	10	5
69			8	15	50	36	2	28	11	2
70			8	34	37	46	26	2	4	8
71			8	22	6	5	25	34	7	5
72			8	2	31	45	37	23	8	4
73			8	48	9	30	28	1	7	8
74			8	29	42	13	16	35	6	8
75			8	50	40	16	32	8	2	11
76			8	45	12	34	24	30	7	10
77			8	28	4	11	17	15	1	3
Sheet1

Thank you all</SPAN></SPAN>

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

 

[motilulla]

Dim cel As Range, rw%, c%, x%
[C5:J5].Copy [M5]
[C5:J5].Copy Sheets("Sheet2").[C5]
[M6:T3209].ClearContents
[M6:M3209].Interior.Pattern = xlNone
Sheets("Sheet2").[C6:J3209].ClearContents
Sheets("Sheet2").[C6:C3209].Interior.Pattern = xlNone
If WorksheetFunction.CountA([D1:J3]) = 0 Then Exit Sub
On Error Resume Next
For rw = 1 To 3
    For Each cel In Cells(rw, "D").Resize(, 7).SpecialCells(xlCellTypeConstants)
        With [C5:C3209].Find(cel, LookAt:=xlWhole).Resize(9, 8)
            .Copy Cells(Rows.Count, "M").End(3)(2)
            .Copy Sheets("Sheet2").Cells(Rows.Count, "C").End(3)(2)
        End With
    Next
Next
For c = 6 To Cells(Rows.Count, "M").End(3).Row Step 9
    If x = 0 Then
        Cells(c, "M").Resize(9).Interior.ColorIndex = 6
        Sheets("Sheet2").Cells(c, "C").Resize(9).Interior.ColorIndex = 6
        x = 1
    Else
        Cells(c, "M").Resize(9).Interior.ColorIndex = 38
        Sheets("Sheet2").Cells(c, "C").Resize(9).Interior.ColorIndex = 38
        x = 0
    End If
Next
On Error GoTo 0

Wow footoo, this is very good idea now it is looking clearer, separately group wise. Thanks a lot for your time you spent to solve full query in a nice way.</SPAN></SPAN>

Have a good day </SPAN></SPAN>

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