VBA filter duplicates in column and copy-filtered area to another location

[motilulla]

Hello,</SPAN></SPAN>

I got a column "I" with values bringing back from formula sum</SPAN></SPAN>
I want to filter all duplicates of this "I" column and copy all C:I columns to location columns L:R</SPAN></SPAN>

Example....</SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2
3
4
5			n1	n2	n3	n4	n5	n6	Sum			n1	n2	n3	n4	n5	n6	Sum
6			0	1	1	1	2	1	6			6	0	5	1	7	6	25
7			0	0	3	2	0	0	5			8	2	6	2	0	7	25
8			0	1	4	3	2	1	11			1	0	4	0	1	3	9
9			2	2	5	0	4	2	15			0	2	0	1	2	4	9
10			3	0	6	0	5	3	17			1	3	0	2	3	0	9
11			2	14	1	2	1	2	22			1	3	1	3	7	1	16
12			3	15	2	4	3	3	30			2	5	2	5	0	2	16
13			4	16	3	0	4	4	31			5	1	1	0	3	7	17
14			5	17	4	0	5	5	36			0	2	3	0	4	8	17
15			6	0	5	1	7	6	25			2	0	0	5	3	0	10
16			8	2	6	2	0	7	25			0	2	1	6	0	1	10
17			9	0	7	4	1	8	29			1	0	0	7	1	2	11
18			11	1	8	5	3	0	28			0	0	1	8	2	0	11
19			0	6	1	4	0	0	11			4	0	2	12	4	4	26
20			0	7	2	6	2	0	17			5	0	3	13	5	0	26
21			2	8	0	8	3	0	21
22			0	0	2	9	0	1	12
23			1	0	4	0	1	3	9
24			0	2	0	1	2	4	9
25			1	3	0	2	3	0	9
26			2	4	0	3	4	1	14
27			4	5	0	4	5	2	20
28			1	3	1	3	7	1	16
29			2	5	2	5	0	2	16
30			3	0	0	6	1	4	14
31			4	0	0	7	2	6	19
32			5	1	1	0	3	7	17
33			0	2	3	0	4	8	17
34			1	3	4	0	5	0	13
35			2	4	5	1	6	0	18
36			0	3	3	4	2	3	15
37			2	0	0	5	3	0	10
38			0	2	1	6	0	1	10
39			1	0	0	7	1	2	11
40			0	0	1	8	2	0	11
41			5	0	0	1	9	3	18
42			6	0	1	2	10	4	23
43			0	1	0	4	11	6	22
44			1	3	0	5	12	7	28
45			2	0	0	7	13	0	22
46			0	2	1	8	0	0	11
47			1	3	2	9	1	1	17
48			2	4	0	10	2	2	20
49			3	0	1	11	3	3	21
50			4	0	2	12	4	4	26
51			5	0	3	13	5	0	26
52			0	1	5	14	0	0	20
53			0	0	0	15	1	0	16
54			0	1	1	16	2	0	20
55			1	3	2	17	3	0	26
Sheet1

Cell Formulas
Range	Formula
I6	=SUM(C6:H6)
I7	=SUM(C7:H7)

Thanks In Advance </SPAN></SPAN>
Using version 2000</SPAN></SPAN>

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

 

[Fluff]

How about

Sub motilulla()
   Dim Cl As Range
   Dim Ky As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("I6", Range("I" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Array(False, Cl.Offset(, -6))
         Else
            .Item(Cl.Value) = Array(True, Union(Cl.Offset(, -6), .Item(Cl.Value)(1)))
         End If
      Next Cl
      For Each Ky In .Keys
         If .Item(Ky)(0) Then
            For Each Cl In .Item(Ky)(1).Areas
               Cl.Resize(, 7).Copy Range("L" & Rows.Count).End(xlUp).Offset(1)
            Next Cl
         End If
      Next Ky
   End With
End Sub

 

[motilulla]

How about

Sub motilulla()
   Dim Cl As Range
   Dim Ky As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("I6", Range("I" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Array(False, Cl.Offset(, -6))
         Else
            .Item(Cl.Value) = Array(True, Union(Cl.Offset(, -6), .Item(Cl.Value)(1)))
         End If
      Next Cl
      For Each Ky In .Keys
         If .Item(Ky)(0) Then
            For Each Cl In .Item(Ky)(1).Areas
               Cl.Resize(, 7).Copy Range("L" & Rows.Count).End(xlUp).Offset(1)
            Next Cl
         End If
      Next Ky
   End With
End Sub

Thank you Fluff, I understand that my title is wrong, and your code is working fine, as it should be according to the title and also as it is explained required.</SPAN></SPAN>

What I am looking for actually is to filter the consecutive duplicate rows, as shown in post#1 (in red). </SPAN></SPAN>

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

 

[Fluff]

In that case, how about

Sub motilulla()
   Dim Cl As Range, Strt As Range
   
   For Each Cl In Range("I6", Range("I" & Rows.Count).End(xlUp))
      If Cl.Value = Cl.Offset(1).Value Then
         If Strt Is Nothing Then Set Strt = Cl
      ElseIf Not Strt Is Nothing Then
         Range(Strt.Offset(, -6), Cl).Copy Range("L" & Rows.Count).End(xlUp).Offset(1)
         Set Strt = Nothing
      End If
   Next Cl
End Sub

 

[motilulla]

In that case, how about

Sub motilulla()
   Dim Cl As Range, Strt As Range
   
   For Each Cl In Range("I6", Range("I" & Rows.Count).End(xlUp))
      If Cl.Value = Cl.Offset(1).Value Then
         If Strt Is Nothing Then Set Strt = Cl
      ElseIf Not Strt Is Nothing Then
         Range(Strt.Offset(, -6), Cl).Copy Range("L" & Rows.Count).End(xlUp).Offset(1)
         Set Strt = Nothing
      End If
   Next Cl
End Sub

Fluff, sorry for the inconvenience, thank you for rewriting the new code it is just perfect! What I had in my mind </SPAN></SPAN>

Thank you for you're twice helps</SPAN></SPAN>

Have a nice weekend</SPAN></SPAN>

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

 

[Fluff]

Glad to help & thanks for the feedback