Macro to pull out multiple entries of same pattern in a cell is not working

kumarma · Apr 26th 2016

I have a worksheet (Sheet1) that contains about 10,000 cells in ColumnD full of textual data

Each Cell in Column D (From D2) contains lot of text with some special charecters in it and out of that i want to pull out a pattern like this ####-### where each # is a digit.

This pattern does not appear at a set place in each cell and there are multiple entries of this in each cell.

My requirement is to pull out a pattern and put it in Column E (If it is only 1 entry as per the pattern)

If there are multiple entries of the same pattern (the return value should be placed in the same row and subsequent columnns)

If it is a single entry i can use this formula but i have multiple entried in one cell. So i am using the below code but it is not working. Not sure what wrong i am doing.

=MID(D2,FIND("-",D2)-4,8)

Code

Sub ExtractPattern()
    On Error Resume Next
    Set SourceSheet = ActiveSheet
    Set TargetSheet = ActiveWorkbook.Sheets("Results")
    If Err = 0 Then
        Worksheets("Results").Delete
    End If
    Worksheets.Add
    ActiveSheet.Name = "Results"
    Set TargetSheet = ActiveSheet
    Cells(1, 1).Value = "Found Codes"
    Cells(1, 1).Font.Bold = True
    iTargetRow = 2
    SourceSheet.Select
    Selection.SpecialCells(xlCellTypeLastCell).Select
    Range(Selection, Cells(1)).Select
    For Each c In Selection.Cells
        If c.Value Like "*####-###*" Then
            sRaw = c.Value
            iPos = InStr(sRaw, "-")
            Do While iPos > 0
                If iPos < 4 Then
                    sRaw = "  " & sRaw
                    iPos = iPos + 4
                End If
                sTemp = Mid(sRaw, iPos - 4, 8)
                sRaw = Mid(sRaw, iPos + 6, Len(sRaw))
                If sTemp Like "##-#####" Then
                    TargetSheet.Cells(iTargetRow, 1) = sTemp
                    iTargetRow = iTargetRow + 1
                Else
                    sRaw = Mid(sTemp, 4, 5) & sRaw
                End If
                iPos = InStr(sRaw, "-")
            Loop
        End If
    Next c
End Sub

Display More

D2 - MS09-062

D3 -
MS06-030
MS08-068
It should Return (MS06-030 in E3, MS08-068 in F3)

D4 -
MS09-037, MS08-048
It should Return (MS09-037 in E4, MS08-048 in F4)

D5-
MS08-033, MS09-028, and MS09-047

D6-
MS08-055, MS09-017, MS10-017, MS10-004, MS10-023, MS10-028, MS09-068, and MS09-027
It should Return (MS08-055 in E6, MS10-017 in F6, MS10-023 in G6,...........)

**pike** · Apr 27th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Hi kumarma,

try..

Code

Option Explicit
Sub ptest()
    Dim SourceSheet As Worksheet, TargetSheet As Worksheet
    Dim iTargetRow As Integer, iTargetColumn As Integer, iPos As Integer
    Dim pCell As Range
    Dim sTemp As String, sPtn


    Set SourceSheet = ActiveSheet
    Set TargetSheet = ActiveWorkbook.Sheets("Results")
    iTargetRow = 2
    iTargetColumn = 5


    For Each pCell In SourceSheet.Range("D2", Cells(Rows.Count, 4).End(xlUp))
        sTemp = pCell.Value


        Do While sTemp <> vbNullString
            If sTemp Like "*??##-###*" Then
                iPos = InStr(sTemp, "-")
                sPtn = Mid(sTemp, iPos - 4, 8)
                If sPtn Like "??##-###" Then
                    'TargetSheet.Cells(iTargetRow, iTargetColumn) = sPtn
                    Cells(iTargetRow, iTargetColumn) = sPtn
                    iTargetColumn = iTargetColumn + 1
                    sTemp = Mid(sTemp, iPos + 1, Len(sTemp))
                Else
                    sTemp = Mid(sTemp, iPos + 1, Len(sTemp))
                End If
            Else
                sTemp = vbNullString
            End If
        Loop
        iTargetColumn = 5
        iTargetRow = iTargetRow + 1
    Next pCell


End Sub

Display More

kumarma · Apr 27th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Hi Pike,

Thanks, but it is not working. It says subscript out of Range.

As per the pattern I think the code needs to be modified

"*??##-###*" to "*??####-###*"

Total 8 characters and before - there are 4 characters

**pike** · Apr 28th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Hi
The pattern "??##-###*" is for the examples provided. You will have to attach a workbook as your pattern "*??####-###*" does not match the data.

**rory** · Apr 28th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Perhaps:

Code

Sub ptest()    Dim SourceSheet           As Worksheet
    Dim n                     As Long
    Dim pCell                 As Range
    Dim oRE                   As VBScript_RegExp_55.RegExp
    Dim matches




    Set oRE = CreateObject("vbscript.regexp")




    Set SourceSheet = ActiveSheet




    With oRE
        .Pattern = "(\w\w\d\d-\d\d\d)"
        .IgnoreCase = True
        .Global = True
    End With
    For Each pCell In SourceSheet.Range("D2", Cells(Rows.Count, 4).End(xlUp))
        Set matches = oRE.Execute(pCell.Value)
        For n = 1 To matches.Count
            pCell.Offset(, n) = matches(n - 1)
        Next n
        Set matches = Nothing
    Next




End Sub

Display More

**pike** · Apr 28th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

he he he

Code

.Pattern = "(\w{2}\d{2}-\d{3})"

**rory** · Apr 28th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Yeah, but that's longer so more typing.

**pike** · Apr 28th 2016

Re: Macro to pull out multiple entries of same pattern in a cell is not working

Doh!
I should have know better than try and be a smart as\{2}

Macro to pull out multiple entries of same pattern in a cell is not working

Participate now!

Share