Matching patterns in table - copying to new worksheet

[theguruguy]

I am trying to take like patterns in cells of a table and copy them to new worksheet. when the matched pattern occurs i need to append the cell in the new worksheet rather than copy over. then i need the script to move to next cell in the row and look for another matched pattern and do the same as above but in the next column of the new worksheet.
here are a few matched patterns I am trying to match are:


grp.app
grp.vdi
grp.ntfs
grp.ctx


there will be additional info at the end of each of those entries, but i just want to collect all the similar ones at that level.


here is a short example of what I have.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]user Id[/TD]
[TD]random groups[/TD]
[TD]random groups[/TD]
[TD]random groups[/TD]
[TD]random groups[/TD]
[/TR]
[TR]
[TD]user1[/TD]
[TD]grp.ctx.1[/TD]
[TD]grp.share.100[/TD]
[TD]grp.app.7[/TD]
[TD]grp.app.15[/TD]
[/TR]
[TR]
[TD]user2[/TD]
[TD]grp.ctx.10[/TD]
[TD]grp.vdi.20[/TD]
[TD]grp.app.10[/TD]
[TD]grp.app.2[/TD]
[/TR]
</tbody>[/TABLE]


This is what i need.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]user Id[/TD]
[TD]Applications[/TD]
[TD]VDI[/TD]
[TD]Fileshare[/TD]
[TD]Citrix[/TD]
[/TR]
[TR]
[TD]user1[/TD]
[TD]grp.app.7
grp.app.15[/TD]
[TD][/TD]
[TD]grp.share.100[/TD]
[TD]grp.ctx.1[/TD]
[/TR]
[TR]
[TD]user2[/TD]
[TD]grp.app.10
grp.app.2[/TD]
[TD] grp.vdi.20[/TD]
[TD][/TD]
[TD]grp.ctx.10[/TD]
[/TR]
</tbody>[/TABLE]


I also need the matching loop to end and go to next row when it reaches an empty column cell value.


once all the matching patterns are copied(appended) to new worksheet. I need the individual cells that have multiple entries sorted alphabetically.


Here is some of the bad code I started. I apologize, I am new to this.

Sub Findandcut()
    Dim row As Long
    Dim lastrow As Integer
    lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).row
    Dim org(1 To lastrow) As String
    Dim startcol As Integer
    startcol = 2
    For row = 1 To lastrow
        ' Check if "condition" appears in the value anywhere.
        org(row) = Worksheets("totals").Cells(row, startcol).Value
        If Cells(row, startcol).Value Like "*grp.app*" Then
            Worksheets("totals").Cells(row, startcol).Value = Cells(row, startcol).Value & ", " & org(row)
        ElseIf Cells(row, startcol).Value Like "*ctx*" Then
            startcol = startcol + 1
            Worksheets("totals").Cells(row, startcol).Value = Cells(row, startcol).Value & ", " & org(row)
        ElseIf Cells(row, startcol).Value Like "*grp.vdi*" Then
            startcol = startcol + 2
            Worksheets("totals").Cells(row, startcol).Value = Cells(row, startcol).Value & ", " & org(row)
            Range("EC" & row).Copy Worksheets("totals").Range("B" & row)
        ElseIf Range("B" & row).Value Like "*ntfs*" Then
            Range("ED" & row).Value = Range("B" & row).Value & ", " & org4
        
        End If
    Next

I changed my strategy and went back to the top to try something different. but i am just at a loss.

 

[DanteAmor]

I pass the macro.

Put in the macro in the next line the patterns to look
patts = Array("app", "vdi", "share", "ctx") 'patterns

Put the column destiny in the next line:
colds = Array("B", "C", "D", "E")
"app" for column "B", "vdi" for column "C", etc

Sub Matching_Patterns()
    Dim h1 As Worksheet, h2 As Worksheet
    Dim i As Long, uc asl long
    '
    Set h1 = Sheets("Sheet1")
    Set h2 = Sheets("totals")
    h2.Rows("2:" & Rows.Count).ClearContents
    patts = Array("app", "vdi", "share", "ctx")     'patterns
    colds = Array("B", "C", "D", "E")               'column destiny
    '
    uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To h1.Range("A" & Rows.Count).End(xlUp).row
        h2.Cells(i, "A").Value = h1.Cells(i, "A").Value
        For j = 2 To uc
            For k = LBound(patts) To UBound(patts)
                If h1.Cells(i, j).Value Like "*" & patts(k) & "*" Then
                    If h2.Cells(i, colds(k)).Value = "" Then
                        h2.Cells(i, colds(k)).Value = h1.Cells(i, j).Value
                    Else
                        h2.Cells(i, colds(k)).Value = h2.Cells(i, colds(k)).Value & Chr(10) & h1.Cells(i, j).Value
                    End If
                    Exit For
                End If
            Next
        Next
    Next
    MsgBox "End"
End Sub

 

[theguruguy]

You are a beast... that is exactly what i needed.

thanks.

 

[DanteAmor]

You're welcome

 

[theguruguy]

You're welcome

one more question for you...

is there a way i can sort the cells that have multiple values (separated by the chr(10)) alphabetically.

thanks.

 

[DanteAmor]

Example, how are those data? and how should they be?

 

[theguruguy]

Example, how are those data? and how should they be?

for example one of the cells in column B might read.

[TABLE="width: 500"]
<tbody>[TR]
[TD]grp.app.websense
grp.app.cynginsis
grp.app.protobase[/TD]
[/TR]
</tbody>[/TABLE]

I would like to values listed alphabetically.

[TABLE="width: 500"]
<tbody>[TR]
[TD]grp.app.cynginsis
grp.app.protobase
grp.app.websense[/TD]
[/TR]
</tbody>[/TABLE]

thanks.

 

[DanteAmor]

Updated macro to order. I added a function Ordenar() to order

Sub Matching_Patterns()
    Dim h1 As Worksheet, h2 As Worksheet
    Dim i As Long
    '
    Set h1 = Sheets("Sheet1")
    Set h2 = Sheets("totals")
    h2.Rows("2:" & Rows.Count).ClearContents
    patts = Array("app", "vdi", "share", "ctx")     'patterns
    colds = Array("B", "C", "D", "E")               'column destiny
    '
    uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To h1.Range("A" & Rows.Count).End(xlUp).row
        h2.Cells(i, "A").Value = h1.Cells(i, "A").Value
        For j = 2 To uc
            For k = LBound(patts) To UBound(patts)
                If h1.Cells(i, j).Value Like "*" & patts(k) & "*" Then
                    If h2.Cells(i, colds(k)).Value = "" Then
                        h2.Cells(i, colds(k)).Value = h1.Cells(i, j).Value
                    Else
                        h2.Cells(i, colds(k)).Value = Ordenar(h2.Cells(i, colds(k)).Value & Chr(10) & h1.Cells(i, j).Value)
                    End If
                    Exit For
                End If
            Next
        Next
    Next
    MsgBox "End"
End Sub
'
Function Ordenar(celda)
    Dim titulos As New Collection
    Set titulos = Nothing
    valores = Split(celda, Chr(10))
    For j = LBound(valores) To UBound(valores)
        agregado = False
        For i = 1 To titulos.Count
            Select Case StrComp(titulos(i), valores(j), vbTextCompare)
            Case 0, 1
                titulos.Add valores(j), Before:=i
                agregado = True
                Exit For 'agrega antes
            End Select
        Next
        If agregado = False Then
            titulos.Add valores(j) 'lo agrega al final
        End If
    Next
    For i = 1 To titulos.Count
        cad = cad & titulos(i) & Chr(10)
    Next
    Ordenar = Left(cad, Len(cad) - 1)
End Function

Regards Dante Amor

 

[theguruguy]

worked perfect...
I have one final question if you dont mind.. you have really saved me tons of time.

now that have all this data sorted. I have a second list.. that has the same id column, but does not match entirely, there are differences.
what i need to do. is take the id column from the list we created and compare it to the second list.. if the cell value matches.. i need to copy the next three adjacent values from the second into the first list.

thanks.

 

[DanteAmor]

I'm not sure if we should continue with this thread, or you should create a new thread with all the details and examples of what you have and what you expect of result.