Help with macro that will delete a set series of rows from column "A".

[IrishMist1748]

Hello!

I need a macro that will delete a repeating series of rows? What I am faced with is a set series of rows (see the series below) in column "A" that is repeated on occasion. What I need to happen is for all the rows in that series to be deleted each time it is found WITHOUT even one set of the series remaining in column "A".

Thank you!

[TABLE="width: 64"]
<colgroup><col style="width:48pt" width="64"> </colgroup><tbody>[TR]
[TD="width: 64"]Type[/TD]
[/TR]
[TR]
[TD]Weight[/TD]
[/TR]
[TR]
[TD]Sizes[/TD]
[/TR]
[TR]
[TD]Gallery[/TD]
[/TR]
[TR]
[TD]Shape[/TD]
[/TR]
[TR]
[TD]Weight[/TD]
[/TR]
[TR]
[TD]Grade[/TD]
[/TR]
[TR]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Shape[/TD]
[/TR]
[TR]
[TD]Weight[/TD]
[/TR]
[TR]
[TD]Grade[/TD]
[/TR]
[TR]
[TD]Type[/TD]
[/TR]
[TR]
[TD]Weight[/TD]
[/TR]
[TR]
[TD]Shape[/TD]
[/TR]
[TR]
[TD]Grade[/TD]
[/TR]
[TR]
[TD]Count[/TD]
[/TR]
[TR]
[TD]Center[/TD]
[/TR]
[TR]
[TD]Accent[/TD]
[/TR]
</tbody>[/TABLE]

 

[mirabeau]

Code below seems to give same output as Peter's. Different from Hiker95's.

Sub delete_consec_values() 
Dim a, b(), crit
Dim i As Long, j As Long, c As Long, lr As Long
lr = Cells(Rows.Count, 1).End(3).Row
ReDim b(1 To lr, 1 To 1)
crit = Array("Type", "Weight", "Sizes", "Gallery", _
    "Shape", "Weight", "Grade", "Count", "Shape", "Weight", _
    "Grade", "Type", "Weight", "Shape", "Grade", "Count", "Center", "Accent")
a = Cells(1).Resize(lr)
Cells(1).Resize(lr).ClearContents
For i = 1 To lr
    If a(i, 1) = crit(0) Then
        c = c + 1
        For j = 1 To UBound(crit)
            c = c + 1
            If crit(j) <> a(i + j, 1) Then c = c - j: GoTo nxti
        Next j
        c = c - UBound(crit)
        i = i + UBound(crit) + 1
    Else
        c = c + 1
    End If
nxti:
b(c, 1) = a(i, 1)
Next i
Cells(1).Resize(c) = b
End Sub

 

[hiker95]

Team,

All three macros produced the exact same results.

But:

Peter_SSs' code ran in 0.484 seconds
mirabeau's code ran in 0.531 seconds
hiker95's code ran in 11.871 seconds


This was a nice chalenge.

And, I will be adding Peter_SSs', and, mirabeau's code to my archives to study, and learn from them.

Thanks everyone, and Happy New Year.

 

[Peter_SSs]

WOW - very, very fast = 0.484 seconds.

This seems simpler to follow to me, still works if there is multi-column data, and is 25-30% faster in my testing.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Delete_Groups_v2()<br>  <SPAN style="color:#00007F">Dim</SPAN> aGroupList, a, b<br>  <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, k <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, GroupSize <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, nc <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>  <SPAN style="color:#00007F">Dim</SPAN> GroupStarted <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><br>  <SPAN style="color:#00007F">Const</SPAN> sGroupList <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "Type, Weight, Sizes, Gallery, Shape, Weight, " _<br>                              & "Grade, Count, Shape, Weight, Grade, Type, " _<br>                              & "Weight, Shape, Grade, Count, Center, Accent"<br>  <br>  aGroupList = Split(sGroupList, ", ")<br>  GroupSize = <SPAN style="color:#00007F">UBound</SPAN>(aGroupList) + 1<br>  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value<br>  rws = <SPAN style="color:#00007F">UBound</SPAN>(a, 1)<br>  <SPAN style="color:#00007F">ReDim</SPAN> b(1 <SPAN style="color:#00007F">To</SPAN> rws, 1 <SPAN style="color:#00007F">To</SPAN> 1)<br>  <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> rws<br>    b(i, 1) = i<br>    <SPAN style="color:#00007F">If</SPAN> GroupStarted <SPAN style="color:#00007F">Then</SPAN><br>      <SPAN style="color:#00007F">If</SPAN> a(i, 1) = aGroupList(j) <SPAN style="color:#00007F">Then</SPAN><br>        j = j + 1<br>        <SPAN style="color:#00007F">If</SPAN> j = GroupSize <SPAN style="color:#00007F">Then</SPAN><br>          GroupStarted = <SPAN style="color:#00007F">False</SPAN><br>          <SPAN style="color:#00007F">For</SPAN> k = 0 <SPAN style="color:#00007F">To</SPAN> GroupSize - 1<br>            b(i - k, 1) = vbNullString<br>          <SPAN style="color:#00007F">Next</SPAN> k<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>      <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">ElseIf</SPAN> a(i, 1) = aGroupList(0) <SPAN style="color:#00007F">Then</SPAN><br>      GroupStarted = <SPAN style="color:#00007F">True</SPAN><br>      j = 1<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>  <SPAN style="color:#00007F">Next</SPAN> i<br>  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _<br>    SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1<br>  Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>  <SPAN style="color:#00007F">With</SPAN> Cells(1, nc).Resize(rws)<br>    .Value = b<br>    Range("A1").Resize(rws, nc).Sort Key1:=Cells(1, nc), Order1:=xlAscending, Header:=xlNo, _<br>      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal<br>    .SpecialCells(xlBlanks).EntireRow.Delete<br>    .ClearContents<br>  <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>  Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[hiker95]

Peter_SSs,

I ran both of your macros on my Lenovo T61, Windows Vista, Excel 2007.

Your original macro ran in 0.531 seconds.
Your latest macro ran in 1.031 seconds.

Both macros are outstanding, and, very very fast.

Thanks again, and again, ......

 

[Peter_SSs]

I ran both of your macros on my Lenovo T61, Windows Vista, Excel 2007.

Your original macro ran in 0.531 seconds.
Your latest macro ran in 1.031 seconds.

Interesting. I made up some test data that apparently roughly matches what you described in post #8 ( 53,468 rows of raw data ... 541 groups of 18 rows per group = 9,738 rows deleted). My original macro took 0.438 (similar to your earlier reported time) and the new one took 0.320.

Disconcertingly, relative speed seems to be influenced by the machine as mirabeau and I have discovered/discussed before:
This thread, starting at about post #14 and also here from post #21

 

[mirabeau]

hiker95,

Just for interest, you might like to try a slightly modified version of my macro, as below.

Do you find a timing difference?

Sub delete_value_2() '53468 rows before, '541 groups del, end row 43730 after
t = Timer
Dim a, b(), crit
Dim i As Long, j As Long, c As Long, lr As Long
lr = Cells(Rows.Count, 1).End(3).Row
ReDim b(1 To lr, 1 To 1)
crit = Array("Type", "Weight", "Sizes", "Gallery", _
    "Shape", "Weight", "Grade", "Count", "Shape", "Weight", _
    "Grade", "Type", "Weight", "Shape", "Grade", "Count", "Center", "Accent")
a = Cells(1).Resize(lr)
Cells(1).Resize(lr).Clear
For i = 1 To lr
    If a(i, 1) = crit(0) Then
        c = c + 1
        For j = 1 To UBound(crit)
            c = c + 1
            If crit(j) <> a(i + j, 1) Then c = c - j: GoTo nxti
        Next j
        c = c - UBound(crit)
        i = i + UBound(crit) + 1
    Else
        c = c + 1
    End If
nxti:
b(c, 1) = a(i, 1)
Next i
Cells(1).Resize(c) = b
Debug.Print Round(Timer - t, 3) & "  mirab2"
End Sub

You can of course do the same with Peter's code . Similar result.



Peter_SSs,

Yes, I do recall previous discussions between us on this sort of thing.

In the thread http://www.mrexcel.com/forum/excel-questions/576769-there-faster-way-do-4.html , the relative times given by your machine did seem to be in a minority.

That of course says nothing about the present thread, about which I make no claims at all other than that my code is easily extended to several columns if need be.

The codes I post on this forum are really just for my own interest. If anyone else likes them then well and good. If not then equally well and good.

 

[hiker95]

mirabeau,

Your latest macro delete_value_2 is faster than your first macro delete_consec_values:

' 0.281 seconds
Sub delete_value_2()


' 0.516 seconds
Sub delete_consec_values()


Both you and Peter_SSs have given me a lot of homework to do..... But, thanks.

 

[mirabeau]

Suppose you want delete all consecutive values "A", "B" and "C" from columnA of a worksheet.

If columnA has only 5 values, "Q", "A", "B", "C", "A" in the first 5 rows, and you delete the consecutively occurring "A", "B", "C", then what should remain?

Do any or all of the codes presented in this thread give this result?

 

[hiker95]

mirabeau,

Suppose you want delete all consecutive values "A", "B" and "C" from columnA of a worksheet.

If columnA has only 5 values, "Q", "A", "B", "C", "A" in the first 5 rows, and you delete the consecutively occurring "A", "B", "C", then what should remain?

The rows that A (row 2), B (row 3), C (row 4) are in would be deleted. And Q would be in row 1, and A would be in row 2.

All the macros that were presented do the above.

 

[IrishMist1748]

Thank you VERY much!