Identify and number Patterns

snb · Dec 5th 2013

Re: Identify and number Patterns

Could someone post holycow's code instead of having to download the whole file ?
Thanks.

**pike** · Dec 5th 2013

Re: Identify and number Patterns

hmmm .. just down loaded the Medifile workbook and it doesnt re-generate the H column for new data .. it work well for the current data and for patterns in that data

it will need to have a reset and quailfy a few bits

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 Application.CountIf(Range("H12:H" & Range("H" & Rows.Count).End(xlUp).Row), [H3]) = 0 Then
        MsgBox "No matching patterns"
        Exit Sub
    End If
    With Application
      .ScreenUpdating = False
  '      .EnableEvents = False
    End With
    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
    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 = Cell.Row
        y = Cell.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
    With Application
 '       .EnableEvents = True
      .ScreenUpdating = True
    End With
    Sheets("Sheet2").Activate
End Sub

Display More

**pike** · Dec 5th 2013

Re: Identify and number Patterns

you probably notice that i have removed the [] or Evaluate as it "is the shortcut convenient when you want to refer to an absolute range. However, it is not as flexible as the Range property as it cannot handle variable input as strings or object references".

best way too work with ranges is full qualify everything
http:// http://msdn.microsoft.com/en-us/library/office/aa139976(v=office.10).aspx

holycow · Dec 5th 2013

Re: Identify and number Patterns

Quote from snb;693980

Could someone post holycow's code instead of having to download the whole file ?
Thanks.

Code

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

Display More

holycow · Dec 5th 2013

Re: Identify and number Patterns

Quote from pike;693981

hmmm .. and it doesnt re-generate the H column for new data ..

Yes I know when larbec chimes in I need to ask him how the big list gets added to - whether by blocks of copy/paste OR by manually typing in.

larbec · Dec 5th 2013

Re: Identify and number Patterns

holycow

I copied and pasted all 400,000 rows from my master file to your file I downloaded

snb · Dec 5th 2013

Re: Identify and number Patterns

If structured properly I think 3 lines of code will suffice.

**pike** · Dec 5th 2013

Re: Identify and number Patterns

arr no have you tested your code..

holycow · Dec 5th 2013

Re: Identify and number Patterns

Hi larbec
how often does the WHOLE big list change? It will be faster if we don't have to update the WHOLE concatenation column every time. An incremental update will be much faster.

snb · Dec 5th 2013

Re: Identify and number Patterns

Can you please translate this into the language of simple humble mortals like ourselves?

Quote from pike;694068

arr no have you tested your code..

holycow · Dec 5th 2013

Re: Identify and number Patterns

The desired output on Sheet 2 Columns L-Q is as follows

the 10 rows prior to first row of pattern as per grid
the 8 rows of the pattern as per grid
the 10 rows immediately after last row of pattern as per grid

followed by a line break

Then repeat this process for each find of the pattern

snb · Dec 5th 2013

Re: Identify and number Patterns

Like ?

Code

Sub M_snb()
    Sheet2.Columns("L:P").Clear
    If Sheet1.Columns(8).Find(Sheet1.Cells(2, 8), Sheet1.Cells(2, 8), xlValues) Is Nothing Then Exit Sub
    
    With Sheet1.Cells(12, 1).CurrentRegion
       .AutoFilter 8, Sheet1.Cells(2, 8).CurrentRegion
       c00 = .Offset(1).Columns(1).SpecialCells(12).Address
       .AutoFilter
    End With
    
    For Each cl In sheet1.Range(c00)
         cl.Offset(-10).Resize(28, 5).Copy Sheet2.Cells(Rows.Count, 12).End(xlUp).Offset(2)
    Next
End Sub

Display More

**KjBox** · Dec 6th 2013

Re: Identify and number Patterns

No, snb

You are still only finding he first row of the input pattern (ie B2 to E2) what is needed is to find a match for the entire 8 rows of the search criteria (ie B2 to E10) then copy each instance of the found pattern together with the 10 preceding and 10 following rows to sheet2. The actual workbook has 400,000 rows of data which can increase.

**KjBox** · Dec 6th 2013

Re: Identify and number Patterns

Tweeked my code a bit and got running time cut by half, including automatic regeneration of filtering columns to account for any changes in the data set, however made (except bitmap pasting, larbec!).

Code

Option Explicit




Sub PatternSearch()
Dim i, j, k As Integer, sn
Dim PatRows, LastRow, LastRow2, CopyRow As Long, PatCols, rCel As Range
Sheets("Sheet1").Activate
LastRow = Range("A" & Rows.Count).End(xlUp).Row
PatRows = [COUNTA(B3:B10)]
    For i = 3 To PatRows
        Set PatCols = Range("B" & i & ":E" & i)
        If Application.WorksheetFunction.CountA(PatCols) < 4 Then
            MsgBox "Row " & i - 2 & " of the search pattern has less than 4 entries"
            Exit Sub
        End If
    Next
Application.ScreenUpdating = False
    Range("B12:E" & LastRow).Copy
    Range("G12").PasteSpecial Paste:=xlPasteValues
    If PatRows > 1 Then
        For i = 1 To PatRows - 1
            Range("G" & 12 + i & ":J" & LastRow).Copy _
            Range("G12").End(xlToRight).Offset(, 1)
        Next
    End If
    sn = Cells(2, 2).CurrentRegion.Resize(PatRows + 2)
    Range("G11", Range("G12").End(xlToRight).Offset(-1)).AutoFilter
    With Cells(12, 7).CurrentRegion
        i = 0
        For j = 2 To UBound(sn)
            If sn(j, 1) <> "" Then
                For k = 1 To 4
                    .AutoFilter (1 + i), sn(j, k)
                    i = i + 1
                Next
            End If
        Next
    End With
    Columns("AM").ClearContents
    For Each rCel In Range("A12:A" & LastRow).SpecialCells(12)
        On Error GoTo ErrHandler
        CopyRow = rCel.Row
        Range("AM" & Rows.Count).End(xlUp).Offset(1) = CopyRow
    Next
    On Error GoTo 0
    Application.Goto ([A1])
    [A1].AutoFilter
LastRow2 = Sheets("Sheet2").Range("L" & Rows.Count).End(xlUp).Row
    If Sheets("Sheet2").Range("L3") = vbNullString Then
    Else
        Sheets("Sheet2").Range("L1:Q" & LastRow2).Clear
    End If
    For Each rCel In Range("AM2", Range("AM2").End(xlDown))
        If rCel.Value = vbNullString Then Exit For
        CopyRow = rCel.Value
        If CopyRow < 23 Then
            Range("A12:F" & CopyRow + PatRows + 10).Copy Sheets("Sheet2").Range("L" & Rows.Count).End(xlUp).Offset(1)
        Else
            Range("A" & CopyRow - 10 & ":F" & CopyRow + 10 + PatRows).Copy Sheets("Sheet2").Range("L" & Rows.Count).End(xlUp).Offset(2)
        End If
    Next
    Range("G12:AL" & LastRow).ClearContents
    Sheets("Sheet2").Columns("Q").AutoFit
    Application.ScreenUpdating = True
    Application.Goto Sheets("Sheet2").Range("L1")
    Exit Sub
ErrHandler:
    MsgBox "No pattern match found.", vbInformation, "No Match"
    Application.Goto ([A1])
    [A1].AutoFilter
    Range("G12:AL" & LastRow).ClearContents
    Application.ScreenUpdating = True
End Sub

Display More

https://www.dropbox.com/s/wn3t…lter%20Code%20larbec.xlsm

snb · Dec 6th 2013

Re: Identify and number Patterns

I doubt it KjBox

see the attachment

**pike** · Dec 6th 2013

Re: Identify and number Patterns

Hey snb,
whats the code; can you post it?

snb · Dec 6th 2013

Re: Identify and number Patterns

Another version if you want to get rid of all those unnecessarily slowing down formulae:

Code

Sub M_snb()
    Sheet2.Columns("L:P").Clear
    c00 = [B2&C2&D2&E2&B3&C3&D3&E3&B4&C4&D4&E4&B5&C5&D5&E5&B6&C6&D6&E6&B7&C7&D7&E7&B8&C8&D8&E8&B9&C9&D9&E9]
    
    With Sheet1.Cells(12, 1).CurrentRegion
       .AutoFilter 2, Sheet1.Cells(2, 2)
       .AutoFilter 3, Sheet1.Cells(2, 3)
       .AutoFilter 4, Sheet1.Cells(2, 4)
       .AutoFilter 5, Sheet1.Cells(2, 5)
       c01 = .Offset(1).Columns(2).SpecialCells(12).Address
       .AutoFilter
    End With
    
    For Each cl In sheet1.Range(c01)
        c02 = ""
        For Each it In cl.Resize(8, 4)
           c02 = c02 & it
        Next
        If c02 = c00 Then cl.Offset(-10, -1).Resize(28, 5).Copy Sheet2.Cells(Rows.Count, 12).End(xlUp).Offset(2)
    Next
End Sub

Display More

snb · Dec 6th 2013

Re: Identify and number Patterns

pike

I started to post the code see: http://www.ozgrid.com/forum/sh…83861&p=694082#post694082. (but apparently unconvincing to KjBox... )

**pike** · Dec 6th 2013

Re: Identify and number Patterns

arrr no .used another data set and doesnt capture them all ..

snb · Dec 6th 2013

Re: Identify and number Patterns

What's the structural difference (not the quantity) of the dataset ?

Can you be more specific about 'doesn't capture them all'

Identify and number Patterns

Participate now!

Share