Code To Remove Only 2 Rows

[Dazzawm]

I have a sheet as below. Whenever there are 2 rows only that match in K then I want them removed to another sheet. This must be when there is one heater blower and one heater in column AF. So in this example below rows 2-4 and 5-7 will remain as there are 3 rows but the rest would be removed to another sheet as there are only 2 rows and there is one description for each.

Excel 2010
	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH
2	M14301280143001																					Heater Blower
3	M14301280143001																					Heater
4	M14301280143001																					Heater
5	M14301280143003																					Heater Blower
6	M14301280143003																					Heater
7	M14301280143003																					Heater
8	M14301280145007																					Heater Blower
9	M14301280145007																					Heater
10	M14301280145011																					Heater Blower
11	M14301280145011																					Heater
12	M14301280145008																					Heater Blower
13	M14301280145008																					Heater
14	M14301280145002																					Heater Blower
15	M14301280145002																					Heater
16	M14301280145005																					Heater Blower
17	M14301280145005																					Heater
Sheet1

 

[Dazzawm]

I hope I explained this ok, please post should you need clarification.

 

[Dazzawm]

Can anyone help with this please?

 

[Dazzawm]

Is this a complicated code I am needing?

 

[Joe4]

Here is one way to do it:

Enter this formula in cell AI2 and copy down for all rows:

=AND(COUNTIF(K:K,K2)=2,COUNTIFS(K:K,K2,AF:AF,"Heater Blower")=1,COUNTIFS(K:K,K2,AF:AF,"Heater")=1)

This should identify every row that needs to be moved by returning "TRUE".
You can then use Advanced Filters to copy them to another sheet, and then delete the TRUE entries from the original sheet.

 

[Joe4]

Here is the VBA code that I came up with to do this:

Sub MyMoveMacro()

    Dim lr As Long
    Dim sh1 As Worksheet, sh2 As Worksheet

    Application.ScreenUpdating = False

'   Set worksheet data resides on
    Set sh1 = Sheets("Sheet1")
'   Set worksheet to copy data to
    Set sh2 = Sheets("Sheet2")

'   Find last row with data in column K
    lr = sh1.Cells(Rows.Count, "K").End(xlUp).Row

'   Populate formula in column AI
    sh1.Range("AI1") = "Move"
    sh1.Range("AI2:AI" & lr).FormulaR1C1 = _
        "=AND(COUNTIF(C[-24],RC[-24])=2,COUNTIFS(C[-24],RC[-24],C[-3],""Heater Blower"")=1,COUNTIFS(C[-24],RC[-24],C[-3],""Heater"")=1)"

'   Filter TRUE entries to new sheet
    sh2.Activate
    sh2.Range("AK1") = "Move"
    sh2.Range("AK2") = "TRUE"
    sh1.Range("K1:AI" & lr).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("AK1:AK2"), CopyToRange:=Range("K1"), Unique:=False
    sh2.Columns("AI:AK").ClearContents
    sh2.Cells.EntireColumn.AutoFit
    
'   Delete TRUE entries from original sheet
    sh1.Activate
    sh1.Range("$K$1:$AI$" & lr).AutoFilter Field:=25, Criteria1:="TRUE"
    Application.DisplayAlerts = False
    ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
    Application.DisplayAlerts = True
    sh1.AutoFilterMode = False
    sh1.Columns("AI:AI").ClearContents

    Application.ScreenUpdating = True

End Sub

Note that you will need to update the value of the "sh1" and "sh2" variables to reflect the names of the sheet that you are working with.
I am also assuming that your data is in columns K:AH. If we need to extend it out to include other columns, the code may need to be altered.

 

[Dazzawm]

Sorry the data starts in A to AV. I thought I would just include the important data to make it clearer.

 

[Joe4]

Yes, it is important to mention that, since you want to move those cells too.

Try this variation:

Sub MyMoveMacro()

    Dim lr As Long
    Dim sh1 As Worksheet, sh2 As Worksheet

    Application.ScreenUpdating = False

'   Set worksheet data resides on
    Set sh1 = Sheets("Sheet1")
'   Set worksheet to copy data to
    Set sh2 = Sheets("Sheet2")

'   Find last row with data in column K
    lr = sh1.Cells(Rows.Count, "K").End(xlUp).Row

'   Populate formula in column AW
    sh1.Range("AW1") = "Move"
    sh1.Range("AW2:AW" & lr).FormulaR1C1 = _
        "=AND(COUNTIF(C[-38],RC[-38])=2,COUNTIFS(C[-38],RC[-38],C[-17],""Heater Blower"")=1,COUNTIFS(C[-38],RC[-38],C[-17],""Heater"")=1)"

'   Filter TRUE entries to new sheet
    sh2.Activate
    sh2.Range("AX1") = "Move"
    sh2.Range("AX2") = "TRUE"
    sh1.Range("A1:AW" & lr).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("AX1:AX2"), CopyToRange:=Range("A1"), Unique:=False
    sh2.Columns("AW:AX").ClearContents
    sh2.Cells.EntireColumn.AutoFit
    
'   Delete TRUE entries from original sheet
    sh1.Activate
    sh1.Range("$A$1:$AW$" & lr).AutoFilter Field:=49, Criteria1:="TRUE"
    Application.DisplayAlerts = False
    ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
    Application.DisplayAlerts = True
    sh1.AutoFilterMode = False
    sh1.Columns("AW:AW").ClearContents

    Application.ScreenUpdating = True

End Sub

 

[Dazzawm]

Thanks Joe I run the code and it completed but nothing moved to sheet 2? It looks like it removed them but didn't paste them onto sheet 2.

 

[Dazzawm]

Don't worry I used the formula and that done the job. Thanks.