Identify and number Patterns

holycow · Dec 6th 2013

Re: Identify and number Patterns

I have superseded the attachment in Post #180 with the following link.

https://www.mediafire.com/?9oi160wvn3ug766 (8.14 mb)

If you don't want to download, here are the macros, changes commented in upper case.

Code

Option Explicit


Sub update()
    Application.ScreenUpdating = False
    Range("H3").FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
    With Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
        .Value = .Value
    End With
    Application.ScreenUpdating = True
End Sub


Sub PatternSearch()
    Dim rng As Range, x As Long, y As Long, Cell
    If Range("A" & Rows.Count).End(xlUp).Row <> Range("H" & Rows.Count).End(xlUp).Row Then
        Call update
    End If 'HAD TO MOVE THIS TO TOP OF PROCEDURE
    If Application.CountIf(Range("H12:H" & Range("H" & Rows.Count).End(xlUp).Row), [H3]) = 0 Then
        MsgBox "No matching patterns"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Sheets("Sheet2").Columns("L:Q").Clear
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    rng.Replace Range("H3").Value, "", , MatchCase:=True
    For Each Cell In rng.SpecialCells(4)
        x = Application.Max(12, Cell.Row - 10) 'PUT THIS BACK
        y = Cell.Row + 17
        Sheets("Sheet1").Range("A" & x & ":F" & y).Copy Sheets("Sheet2").Range("L" & Sheets("Sheet2").Rows.Count).End(xlUp)(3)
    Next
    rng.SpecialCells(4) = Range("H3").Value
    Application.ScreenUpdating = True
    Sheets("Sheet2").Activate
End Sub

Display More

snb was on the verge of a much better solution, but like Kjbox, I was getting debug in same place.

**KjBox** · Dec 6th 2013

Re: Identify and number Patterns

holycow

The patterns that larbec gave in posts #176 and #178 are giving the same 400 error using your code as they do in my code. I am trying to see what the problem is, can you do the same?

snb and I still looking at the array solution.

**pike** · Dec 6th 2013

Re: Identify and number Patterns

maybe .. Must remember this is larbec thread. Holycow your solution has merit and works.
larbec will beable to take the solution to his Excel class and it will be easily explained for his level of learning. The syntax and methods are within the conventions of any book he buys.

holycow · Dec 7th 2013

Re: Identify and number Patterns

Kjbox re #182 I am checking now

**pike** · Dec 7th 2013

Re: Identify and number Patterns

arrr man

Error 400 in data #176 and #178 is because the Ifcount error .It shows 26 matches when there are zero . then the bug on specialcells

Code

Option Explicit
Sub update()
    Application.ScreenUpdating = False
    Range("H12:H" & Range("H" & Rows.Count).End(xlUp).Row).ClearContents
    Range("H3").FormulaR1C1 = _
    "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
    With Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
        .Value = .Value
    End With
    Application.ScreenUpdating = True
End Sub

Display More

Code

Sub PatternSearch()
    Dim rng As Range, x As Long, y As Long, xCell
    Application.ScreenUpdating = False
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    If Range("A" & Rows.Count).End(xlUp).Row <> Range("H" & Rows.Count).End(xlUp).Row Then
        Call update
    End If
    Sheets("Sheet2").Columns("L:Q").Clear
    rng.Replace Range("H3").Value, "", , MatchCase:=True
    If rng.SpecialCells(2).Count <> rng.Count Then
        For Each xCell In rng.SpecialCells(4)
            x = xCell.Row
            y = xCell.Row + 7
            Sheets("Sheet1").Range("A" & x & ":F" & y).Copy Sheets("Sheet2").Range("L" & Sheets("Sheet2").Rows.Count).End(xlUp)(3)
        Next
        rng.SpecialCells(4) = Range("H3").Value
        Sheets("Sheet2").Activate
    Else
        MsgBox "No Matches"
    End If
    Application.ScreenUpdating = True
    Set rng = Nothing
End Sub

Display More

**KjBox** · Dec 7th 2013

Re: Identify and number Patterns

I was just about to post the same thing!

Question is why should one number set in H3 bring up the 'No pattern matches' message when no match is found while another set does not?

Also strange that the same error occurs with my filter method, while other non-matching patterns bring up the message ok.

holycow · Dec 7th 2013

Re: Identify and number Patterns

this should have caught it

Code

If Application.CountIf(Range("H12:H" & Range("H" & Rows.Count).End(xlUp).Row), Range("H3").Value) = 0 Then
        MsgBox "No matching patterns"
        Exit Sub
    End If

**pike** · Dec 7th 2013

Re: Identify and number Patterns

Think countif has a charactor length limit of about 12 ish and the pattern was 32
it was also why the code was slow.. it much faster now with it removed..

**KjBox** · Dec 7th 2013

Re: Identify and number Patterns

It does not because CountIf is returning 26 with this number set, not 0. A physical check of all data confirms it should be 0

holycow · Dec 7th 2013

Re: Identify and number Patterns

So limitation of Excel COUNTIF.

Bypass Excel

Code

If rng.Find(Range("H3").Value) Is Nothing Then
        MsgBox "No matching patterns"
        Exit Sub
    End If

holycow · Dec 7th 2013

Re: Identify and number Patterns

Ooops

Code

Sub PatternSearch()
    Dim rng As Range, x As Long, y As Long, Cell
    If Range("A" & Rows.Count).End(xlUp).Row <> Range("H" & Rows.Count).End(xlUp).Row Then
        Call update
    End If
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    If rng.Find(Range("H3").Value) Is Nothing Then
        MsgBox "No matching patterns"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Sheets("Sheet2").Columns("L:Q").Clear
    rng.Replace Range("H3").Value, ""
    For Each Cell In rng.SpecialCells(4)
        x = Application.Max(12, Cell.Row - 10)
        y = Cell.Row + 17
        Sheets("Sheet1").Range("A" & x & ":F" & y).Copy Sheets("Sheet2").Range("L" & Sheets("Sheet2").Rows.Count).End(xlUp)(3)
    Next
    rng.SpecialCells(4) = Range("H3").Value
    Application.ScreenUpdating = True
    Sheets("Sheet2").Activate
End Sub

Display More

**KjBox** · Dec 7th 2013

Re: Identify and number Patterns

That sorted it for me.

holycow · Dec 7th 2013

Re: Identify and number Patterns

Just found one more small problem

Code

Sub update()
    Application.ScreenUpdating = False
    With Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
        .ClearContents
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
        '**INTERMITTENT PROBLEM HERE**
        .Value = .Value
    End With
    Application.ScreenUpdating = True
End Sub

Display More

Sometimes .Value = .Value kicks in before all cells are populated and those remaining cells end up with 0 in them.

Need to put an Application.Wait in here but not sure how long to put or if there's a better option.

**pike** · Dec 7th 2013

Re: Identify and number Patterns

try...

Code

Option Explicit
Sub update()
    Dim rng    As Range
    Application.ScreenUpdating = False
    Range("H12:H" & Range("H" & Rows.Count).End(xlUp).Row).ClearContents
    Range("H3").FormulaR1C1 = _
    "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    With rng
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
       
    End With
    rng.Value = rng.Value
    Set rng = Nothing
    Application.ScreenUpdating = True
End Sub

Display More

holycow · Dec 7th 2013

Re: Identify and number Patterns

The following all works for me

Code

Option Explicit


Sub update()
    Dim rng2 As Range
    Application.ScreenUpdating = False
    Set rng2 = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    Range("H3").FormulaR1C1 = _
    "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
    With rng2
        .ClearContents
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
    End With
    rng2.Value = rng2.Value
    Set rng2 = Nothing
    Application.ScreenUpdating = True
End Sub


Sub PatternSearch()
    Dim rng As Range, x As Long, y As Long, Cell
    If Range("A" & Rows.Count).End(xlUp).Row <> Range("H" & Rows.Count).End(xlUp).Row Then
        Call update
    End If
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    If rng.Find(Range("H3").Value) Is Nothing Then
        MsgBox "No matching patterns"
        Set rng = Nothing '** ADDED THIS **
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Sheets("Sheet2").Columns("L:P").Clear
    rng.Replace Range("H3").Value, ""
    For Each Cell In rng.SpecialCells(4)
        x = Application.Max(12, Cell.Row - 10)
        y = Cell.Row + 17
        Sheets("Sheet1").Range("A" & x & ":F" & y).Copy Sheets("Sheet2").Range("L" & Sheets("Sheet2").Rows.Count).End(xlUp)(3)
    Next
    rng.SpecialCells(4) = Range("H3").Value
    Set rng = Nothing
    Application.ScreenUpdating = True
    Sheets("Sheet2").Activate
End Sub

Display More

holycow · Dec 7th 2013

Re: Identify and number Patterns

Link at #181 contains up to date workbook

larbec · Dec 7th 2013

Re: Identify and number Patterns

Let me recheck. Zeros should not be in my code. So sorry

**pike** · Dec 7th 2013

Re: Identify and number Patterns

no need to be sorry .. i think you will find all the errors have been handled in the code

holycow · Dec 7th 2013

Re: Identify and number Patterns

I don't think it was larbec's bad, more of an excel limitation.

I have done a little more bug proofing. Human nature is someone is going to press either the Run button or the Update button, either without entering anything in grid or with no data in the big list.

Latest workbook here
https://www.mediafire.com/?9oi160wvn3ug766 (8.17 mb)

The amended macros

Code

Option Explicit


Sub update()
    Dim rng2 As Range
    If [COUNTA(B12:E19)] <> 32 Then
        MsgBox "Enter data starting in Row 12"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set rng2 = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    Range("H3").FormulaR1C1 = _
    "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
    With rng2
        .ClearContents
        .NumberFormat = "0"
        .FormulaR1C1 = _
        "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&R[1]C[-6]&R[1]C[-5]&R[1]C[-4]&R[1]C[-3]&R[2]C[-6]&R[2]C[-5]&R[2]C[-4]&R[2]C[-3]&R[3]C[-6]&R[3]C[-5]&R[3]C[-4]&R[3]C[-3]&R[4]C[-6]&R[4]C[-5]&R[4]C[-4]&R[4]C[-3]&R[5]C[-6]&R[5]C[-5]&R[5]C[-4]&R[5]C[-3]&R[6]C[-6]&R[6]C[-5]&R[6]C[-4]&R[6]C[-3]&R[7]C[-6]&R[7]C[-5]&R[7]C[-4]&R[7]C[-3]"
        .NumberFormat = "@"
    End With
    rng2.Value = rng2.Value
    Set rng2 = Nothing
    Application.ScreenUpdating = True
End Sub


Sub PatternSearch()
    Dim rng As Range, x As Long, y As Long, Cell
    If [COUNTA(B12:E19)] <> 32 Then
        MsgBox "Enter data starting in Row 12"
        Exit Sub
    End If
    If [COUNTA(B3:E10)] <> 32 Then
        MsgBox "Enter pattern to search for in upper grid"
        Exit Sub
    End If
    If Range("A" & Rows.Count).End(xlUp).Row <> Range("H" & Rows.Count).End(xlUp).Row Then
        Call update
    End If
    Set rng = Range("H12:H" & Range("A" & Rows.Count).End(xlUp).Row)
    If rng.Find(Range("H3").Value) Is Nothing Then
        MsgBox "No matching patterns"
        Set rng = Nothing
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Sheets("Sheet2").Columns("L:Q").Clear
    rng.Replace Range("H3").Value, ""
    For Each Cell In rng.SpecialCells(4)
        x = Application.Max(12, Cell.Row - 10)
        y = Cell.Row + 17
        Sheets("Sheet1").Range("A" & x & ":F" & y).Copy Sheets("Sheet2").Range("L" & Sheets("Sheet2").Rows.Count).End(xlUp)(3)
    Next
    rng.SpecialCells(4) = Range("H3").Value
    Set rng = Nothing
    Application.ScreenUpdating = True
    Sheets("Sheet2").Activate
End Sub

Display More

**KjBox** · Dec 7th 2013

Re: Identify and number Patterns

holycow

Neat additions

larbec

Hope this finally gets a fully workable solution for you, enjoy working with it!

You need only click the 'Update' button if you replace data or add more rows than you remove (or vise versa). The 'Run' macro checks that the last row of data is the same as the last row of the generated number set in column F, if not then column F is updated automatically. The 'Run' macro cannot tell if data has been changed without the total number of rows being altered, so if such a change has been made you need to click the 'Update' button after making the data change.

May I suggest that, with the latest workbook uploaded by holycow (or whatever workbook you are using if you just amended the code) you highlight the full data set and standardise the formatting. Presently there are cells formatted as general, number and I am sure I even saw a text format in there somewhere. Format all to 'Number' with 0 decimal places. At the same time you could set all cells to the same font type and size and bold or regular, there is a mixture of all of those currently.

To highlight the full data set go to cell F12, hold down CTRL and SHIFT, press the down arrow, then, still holding down CTRL+SHIFT, press the left arrow.

Identify and number Patterns

Participate now!

Share