Split the result by sum in various sheets

[motilulla]

Using Excel 2010

Hello,

I have sheet “Result 100 to 114” in which I have results with sum in-between 100 to 114. Than I have 14 sheets with name 100-101-102 till 114, I want a VBA that which can copy only values of each sum in there corresponding sheet 100 in 100 sheet, 101 in 101 sheets here is example of 2 sums 100 and 101

Note: please I want a macro which can be used in Excel 2000 also.
Data sheet.......

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6	2006	22/01/2006	8	12	17	21	23	30		111
7	2006	26/02/2006	1	5	18	26	27	31		108
8	2006	05/03/2006	10	11	17	18	24	26		106
9	2006	19/03/2006	7	10	18	22	27	30		114
10	2006	11/06/2006	3	10	15	20	25	28		101
11	2006	16/07/2006	7	8	16	19	28	30		108
12	2006	20/08/2006	13	16	17	19	20	26		111
13	2006	24/09/2006	1	7	18	21	24	29		100
14	2006	22/10/2006	2	12	18	21	22	31		106
15	2007	21/06/2007	6	16	19	22	24	27		114
16	2007	30/06/2007	2	9	13	25	26	30		105
17	2007	07/07/2007	1	6	18	24	26	27		102
18	2007	19/07/2007	2	11	19	21	23	24		100
19	2007	21/07/2007	6	19	20	21	22	23		111
20	2007	26/07/2007	6	9	10	25	26	28		104
21	2007	12/08/2007	10	12	17	19	25	27		110
22	2007	16/09/2007	9	11	12	20	25	30		107
23	2007	23/09/2007	5	17	18	21	23	26		110
24	2007	30/09/2007	6	10	12	20	24	31		103
25	2007	11/11/2007	11	13	18	21	24	27		114
26	2007	18/11/2007	2	5	13	25	27	29		101
27	2007	02/12/2007	2	9	20	22	23	25		101
28	2007	09/12/2007	2	13	20	23	26	29		113
29	2008	28/02/2008	7	11	15	22	24	26		105
30	2008	02/03/2008	1	12	13	24	25	29		104
31	2008	15/05/2008	2	3	16	25	27	28		101
32	2008	10/07/2008	4	11	12	22	25	26		100
33	2008	12/07/2008	7	15	16	18	20	31		107
34	2008	17/07/2008	2	10	16	19	24	30		101
35	2008	15/08/2008	5	7	16	19	22	31		100
36	2008	24/08/2008	4	9	20	22	27	29		111
37	2008	14/09/2008	4	13	19	20	24	25		105
38	2008	21/09/2008	11	12	16	17	27	31		114
39	2008	23/11/2008	5	10	19	20	22	31		107
40	2009	11/01/2009	4	9	19	23	26	28		109
41	2009	01/02/2009	3	13	14	19	25	26		100
42	2009	22/02/2009	7	13	16	17	22	27		102
43	2009	03/05/2009	8	10	15	18	19	30		100
44	2009	21/06/2009	6	7	14	21	24	30		102
45	2009	20/08/2009	5	13	18	21	22	26		105
46	2009	15/11/2009	4	5	20	26	28	29		112
47	2010	03/01/2010	1	2	22	23	24	30		102
48	2010	07/02/2010	7	9	13	19	25	29		102
49	2010	19/03/2010	9	13	17	19	20	24		102
50	2010	16/05/2010	2	9	18	21	25	27		102
51	2010	20/06/2010	10	12	13	21	26	30		112
52	2010	22/07/2010	4	5	17	22	27	28		103
53	2010	17/09/2010	1	8	21	23	24	25		102
54	2010	19/09/2010	3	9	19	23	28	30		112
55	2010	26/12/2010	3	5	18	25	26	27		104
56	2011	09/01/2011	11	13	16	20	25	27		112
57	2011	20/02/2011	6	7	8	26	27	31		105
58	2011	22/04/2011	10	15	16	20	25	26		112
59	2011	27/05/2011	3	11	15	23	28	30		110
60	2011	23/06/2011	11	12	13	16	27	31		110
61	2012	04/03/2012	9	12	13	16	28	31		109
62	2012	08/04/2012	7	14	17	18	25	28		109
63	2013	29/03/2013	4	7	12	27	29	30		109
64	2013	25/07/2013	1	10	19	24	26	30		110
65	2014	13/04/2014	8	15	17	19	20	31		110
66	2014	20/06/2014	1	10	11	27	30	31		110
Result 100 To 114

Example....copy value expected filtered sum of100 here

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6	2006	24/09/2006	1	7	18	21	24	29		100
7	2007	19/07/2007	2	11	19	21	23	24		100
8	2008	10/07/2008	4	11	12	22	25	26		100
9	2008	15/08/2008	5	7	16	19	22	31		100
10	2009	01/02/2009	3	13	14	19	25	26		100
11	2009	03/05/2009	8	10	15	18	19	30		100
12
13
100

Example....copy value expected filtered sum of100 here

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6	2006	11/06/2006	3	10	15	20	25	28		101
7	2007	18/11/2007	2	5	13	25	27	29		101
8	2007	02/12/2007	2	9	20	22	23	25		101
9	2008	15/05/2008	2	3	16	25	27	28		101
10	2008	17/07/2008	2	10	16	19	24	30		101
11
12
101

Regards,
Moti

 

[LazyBug]

Try this:

Sub mtll()
Dim sh As Worksheet, c As Range, r As Range, d As Object, k
    Set d = CreateObject("Scripting.Dictionary")
    Set sh = ActiveWorkbook.Worksheets("Result 100 to 114")
    With sh
        If .FilterMode Then .ShowAllData
        Set r = .UsedRange
        With d
            For Each c In Range("J6:J" & Cells(6, 10).End(4).Row)
                .Item(c.Value) = c.Value
            Next c
            
            For Each k In .keys
                r.AutoFilter Field:=10, Criteria1:=k
                r.SpecialCells(xlCellTypeVisible).Copy
                ActiveWorkbook.Worksheets(CStr(k)).Paste
            Next k
        End With
        .ShowAllData
    End With
End Sub

 

[motilulla]

Try this:

Sub mtll()
Dim sh As Worksheet, c As Range, r As Range, d As Object, k
    Set d = CreateObject("Scripting.Dictionary")
    Set sh = ActiveWorkbook.Worksheets("Result 100 to 114")
    With sh
        If .FilterMode Then .ShowAllData
        Set r = .UsedRange
        With d
            For Each c In Range("J6:J" & Cells(6, 10).End(4).Row)
                .Item(c.Value) = c.Value
            Next c
           
            For Each k In .keys
                r.AutoFilter Field:=10, Criteria1:=k
                r.SpecialCells(xlCellTypeVisible).Copy
                ActiveWorkbook.Worksheets(CStr(k)).Paste
            Next k
        End With
        .ShowAllData
    End With
End Sub

@LazyBug, VBA is not working correctly it deletes headers and copy any ware in sheet apart of that if I run again it keeps duplicating data it must has to past A6:j6 below.

Please see the results below....

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16			YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
17			2006	24/09/2006	1	7	18	21	24	29		100
18			2007	19/07/2007	2	11	19	21	23	24		100
19			2008	10/07/2008	4	11	12	22	25	26		100
20			2008	15/08/2008	5	7	16	19	22	31		100
21			2009	01/02/2009	3	13	14	19	25	26		100
22			2009	03/05/2009	8	10	15	18	19	30		100
23
24
25
26
27
100

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	2006	11/06/2006	3	10	15	20	25	28		101
3	2007	18/11/2007	2	5	13	25	27	29		101
4	2007	02/12/2007	2	9	20	22	23	25		101
5	2008	15/05/2008	2	3	16	25	27	28		101
6	2008	17/07/2008	2	10	16	19	24	30		101
7	2007	18/11/2007	2	5	13	25	27	29		101
8	2007	02/12/2007	2	9	20	22	23	25		101
9	2008	15/05/2008	2	3	16	25	27	28		101
10	2008	17/07/2008	2	10	16	19	24	30		101
11
101

Regards,
Moti

 

[LazyBug]

I copied the data you gave as an example, and the code works as you said in the #1 post: it copies the data for each of the amounts with the headers in column J to an empty sheet with the corresponding name. Did I misunderstand the challenge?

 

[motilulla]

I copied the data you gave as an example, and the code works as you said in the #1 post: it copies the data for each of the amounts with the headers in column J to an empty sheet with the corresponding name. Did I misunderstand the challenge?

Hello LazyBug, let me explain and make the example sheet simpler with sums 100 & 101, data sheet “Result 100 to 114” has 5 header rows, data start from the row 6 below. And also I got 2 sheet named 100 & 101 already have 5 row header I want data must be copied and paste in these sheets from row 6 to below.(I do not have 100 & 101 sheets empty).

Secondly before running the macro you select for example cell D6 in sheet 100 & select any cell you want in the sheet 101 and come back to data sheet “Result 100 to 114” and run the macro see what happen. It pastes data within selected cells.

Here is how my sheets look like. Please can you check it?
Data sheet....

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6	2006	11/06/2006	3	10	15	20	25	28		101
7	2006	24/09/2006	1	7	18	21	24	29		100
8	2007	19/07/2007	2	11	19	21	23	24		100
9	2007	18/11/2007	2	5	13	25	27	29		101
10	2007	02/12/2007	2	9	20	22	23	25		101
11	2008	15/05/2008	2	3	16	25	27	28		101
12	2008	10/07/2008	4	11	12	22	25	26		100
13	2008	17/07/2008	2	10	16	19	24	30		101
14	2008	15/08/2008	5	7	16	19	22	31		100
15	2009	01/02/2009	3	13	14	19	25	26		100
16	2009	03/05/2009	8	10	15	18	19	30		100
17
18
19
20
Result 100 To 114

Sheet100...

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
101

Sheet 101....

LotoTurf.xls
	A	B	C	D	E	F	G	H	I	J
1	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
2	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
3	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
4	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
5	YEAR	DATE	n1	n2	n3	n4	n5	n6	EM1	Sum
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
101

Regards,
Moti

 

[kevin9999]

This is pretty much what @LazyBug suggested, with just a couple of minor tweaks. Please try it on a copy of your workbook:

Option Explicit
Sub motilulla()
    Dim ws As Worksheet
    Set ws = Worksheets("Result 100 to 114")
    Dim d As Object, c As Range, i As Long, a, b
    Set d = CreateObject("scripting.dictionary")
    a = ws.Range("J6", ws.Cells(Rows.Count, "J").End(xlUp))
    
    With ws
        With d
            For i = 1 To UBound(a, 1)
            d(a(i, 1)) = 1
            Next i
            For Each b In .keys
                With ws.Range(ws.Cells(5, 1), ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row, _
                    ws.Cells(1, Columns.Count).End(xlToLeft).Column))
                    .AutoFilter 10, b
                    .Offset(1).Resize(.Rows.Count - 1).Copy Worksheets(CStr(b)).Cells(Rows.Count, "A").End(xlUp).Offset(1)
                    .AutoFilter
                End With
            Next b
        End With
    End With
End Sub

 

[motilulla]

This is pretty much what @LazyBug suggested, with just a couple of minor tweaks. Please try it on a copy of your workbook:

Option Explicit
Sub motilulla()
    Dim ws As Worksheet
    Set ws = Worksheets("Result 100 to 114")
    Dim d As Object, c As Range, i As Long, a, b
    Set d = CreateObject("scripting.dictionary")
    a = ws.Range("J6", ws.Cells(Rows.Count, "J").End(xlUp))
   
    With ws
        With d
            For i = 1 To UBound(a, 1)
            d(a(i, 1)) = 1
            Next i
            For Each b In .keys
                With ws.Range(ws.Cells(5, 1), ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row, _
                    ws.Cells(1, Columns.Count).End(xlToLeft).Column))
                    .AutoFilter 10, b
                    .Offset(1).Resize(.Rows.Count - 1).Copy Worksheets(CStr(b)).Cells(Rows.Count, "A").End(xlUp).Offset(1)
                    .AutoFilter
                End With
            Next b
        End With
    End With
End Sub

Hello @kevin9999, yes your tweaks are just perfect code worked like magic every copy goes into their corresponding sum sheet and paste it below header from row 6 to down.

Have a nice weekend and good luck.

Regards,
Moti

 

[kevin9999]

Hello @kevin9999, yes your tweaks are just perfect code worked like magic every copy goes into their corresponding sum sheet and paste it below header from row 6 to down.

Have a nice weekend and good luck.

Regards,
Moti

Glad we were able to help Moti, and thanks for the feedback