Sorting by method into individual sheets

I am stumped on this problem and would really appreciate some help. I have a list of Quality Controls and Patient Data. I need to separate this data into individual sheets within the workbook using a code. I have attached an example of the list in the "Accession" sheet. Originally, this workbook would only contain this tab with only information in the first three columns. I have added the table on this sheet to show how the data needs to be split. Essentially, the data needs to be split based on the Method Letter that is attached to the end of the long accession numbers, like 1532105R_O. This would be an O method. Some have R's after the accession # but those can be ignored. Only the letters preceded by an underscore denotes the method, and some have multiple methods like 1532105R_O_B_G. Tabs would need to be added with the method type as the name of each sheet. To show how they will need to be split, this workbook already has those tabs made and named appropriately. If a method type is not used in the list, as with the "A" method, then a tab will not need to be made and it can be ignored. If I had a code that could automatically do this for me then it would save a massive amount of time and prevent several human errors. Thank you in advance for the help.


Sorting methods Into indiv sheets.xlsx

hi RaydenUK,

can you go in detail for B and D methods for getting provided result on respective sheets.
I do not understand why 15029859RX5_L goes to B sheet. Check Tray looks to go to any method by default. I do not understand why HYDRO goes to D sheet.

I added those individual method sheets on fairly quickly, so I may have put some of the wrong ones in each sheet. The table on the first sheet has the exact layout though. Sorry about that. Yes they all have a blank, negative, and check tray. The B should not have an L with it and D should not have a Hydro. Like I said I must have let those slip by me. Thanks for catching that.

Let's see if this is what you wanted.

Sub test()
    Dim a, tbl, i As Long, ii As Long, iii As Long
    Dim dic As Object, e, RegX As Object, m As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set RegX = CreateObject("VBScript.RegExp")
    With Sheets("accession")
        tbl = .[g1].CurrentRegion.Value
        With .Cells(1).CurrentRegion
            a = .Value
            For i = 2 To UBound(tbl, 1)
                dic(tbl(i, 1)) = Empty
            Next
            With RegX
                .Global = True: .IgnoreCase = True
                .Pattern = "_([" & Join(dic.keys, "") & "])(?=(_|$))"
            End With
            For i = 2 To UBound(tbl, 1)
                For ii = 1 To UBound(a, 1)
                    If RegX.test(a(ii, 1)) Then
                        For Each m In RegX.Execute(a(ii, 1))
                            GetRows dic, m.submatches(0), .Rows(ii)
                        Next
                    Else
                        For iii = 2 To UBound(tbl, 2)
                            If a(ii, 1) = tbl(i, iii) Then
                                GetRows dic, tbl(i, 1), .Rows(ii)
                                Exit For
                            End If
                        Next
                    End If
                Next
            Next
        End With
    End With
    For Each e In dic
        If Not IsSheetExists(e) Then Sheets.Add.Name = e
        Sheets(e).Cells.Clear
        If Not IsEmpty(dic(e)) Then dic(e).Copy Sheets(e).Cells(1)
        Sheets(e).Columns.AutoFit
    Next
End Sub

Private Sub GetRows(dic As Object, ByVal myMethod As String, r As Range)
    If IsEmpty(dic(myMethod)) Then
        Set dic(myMethod) = r
    Else
        Set dic(myMethod) = Union(dic(myMethod), r)
    End If
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(txt).Name)
    On Error GoTo 0
End Function

Originally Posted by RaydenUK

If a method is not present in the accession numbers, like A, then don't include it.

Originally Posted by RaydenUK

Also the table would need to be put on its own sheet that is hidden, possibly named "Master", because I have other code that uses that space in the "Accession" Sheet.

What do you mean?

This includes "Check_Tray"

Sub test()
    Dim a, tbl, i As Long, ii As Long, iii As Long
    Dim dic As Object, e, RegX As Object, m As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set RegX = CreateObject("VBScript.RegExp")
    With Sheets("accession")
        tbl = .[g1].CurrentRegion.Value
        With .Cells(1).CurrentRegion
            a = .Value
            For i = 2 To UBound(tbl, 1)
                dic(tbl(i, 1)) = Empty
            Next
            With RegX
                .Global = True: .IgnoreCase = True
                .Pattern = "_([" & Join(dic.keys, "") & "])(?=(_|$))"
            End With
            For ii = 1 To UBound(a, 1)
                If a(ii, 1) = "Check_Tray" Then
                    For Each e In dic
                        GetRows dic, e, .Rows(ii)
                    Next
                ElseIf RegX.test(a(ii, 1)) Then
                    For Each m In RegX.Execute(a(ii, 1))
                        GetRows dic, m.submatches(0), .Rows(ii)
                    Next
                Else
                    For i = 2 To UBound(tbl, 1)
                        If RegX.test(a(ii, 1)) Then
                            For Each m In RegX.Execute(a(ii, 1))
                                GetRows dic, m.submatches(0), .Rows(ii)
                            Next
                        Else
                            For iii = 2 To UBound(tbl, 2)
                                If a(ii, 1) = tbl(i, iii) Then
                                    GetRows dic, tbl(i, 1), .Rows(ii)
                                    Exit For
                                End If
                            Next
                        End If
                    Next
                End If
            Next
        End With
    End With
    For Each e In dic
        If IsSheetExists(e) Then
            Sheets(e).Cells.Clear
            If Not IsEmpty(dic(e)) Then dic(e).Copy Sheets(e).Cells(1)
            Sheets(e).Columns.AutoFit
        End If
    Next
End Sub

Private Sub GetRows(dic As Object, ByVal myMethod As String, r As Range)
    If IsEmpty(dic(myMethod)) Then
        Set dic(myMethod) = r
    Else
        Set dic(myMethod) = Union(dic(myMethod), r)
    End If
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(txt).Name)
    On Error GoTo 0
End Function

Also the table would need to be put on its own sheet that is hidden, possibly named "Master", because I have other code that uses that space in the "Accession" Sheet.

If you look at method "A" then you can see that there are no patient accession numbers, like 1543215. So if a method doesn't include a sequence of numbers then it doesn't need to make a sheet for it. Also is there any way that the table that is used to show what methods get what information can be moved? Preferably to its own sheet? Thank you for the help, I greatly appreciate it!

Sorting methods Into indiv sheets2.xlsm

This will hopefully illustrate what I am talking about. Sorry for being so confusing, but the table I am referring to is the one that was originally on the "Accession" sheet in cell G1. I just need to move it to a different sheet. In this workbook I have moved it to the sheet named "Master" in cell A1.

OK then

Sub test()
    Dim a, tbl, i As Long, ii As Long, iii As Long
    Dim myMethod As String, ws As Worksheet
    Dim dic As Object, e, RegX As Object, m As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If (ws.Name <> "Accession") * (ws.Name <> "Master") Then ws.Delete
    Next
    Application.DisplayAlerts = True
    Set dic = CreateObject("Scripting.Dictionary")
    Set RegX = CreateObject("VBScript.RegExp")
    tbl = Sheets("master").Cells(1).CurrentRegion.Value
    With Sheets("accession").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(tbl, 1)
            dic(tbl(i, 1)) = Empty
        Next
        With RegX
            .Global = True: .IgnoreCase = True
            .Pattern = "_([" & Join(dic.keys, "") & "])(?=(_|$))"
        End With
        For ii = 1 To UBound(a, 1)
            If RegX.test(a(ii, 1)) Then
                For Each m In RegX.Execute(a(ii, 1))
                    myMethod = m.submatches(0)
                    If Not IsSheetExists(myMethod) Then
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = myMethod
                    End If
                    GetRows dic, myMethod, .Rows(ii)
                Next
            Else
                For i = 2 To UBound(tbl, 1)
                    If RegX.test(a(ii, 1)) Then
                        For Each m In RegX.Execute(a(ii, 1))
                            GetRows dic, m.submatches(0), .Rows(ii)
                        Next
                    Else
                        For iii = 2 To UBound(tbl, 2)
                            If a(ii, 1) = tbl(i, iii) Then
                                GetRows dic, tbl(i, 1), .Rows(ii)
                                Exit For
                            End If
                        Next
                    End If
                Next
            End If
        Next
    End With
    For Each e In dic
        If IsSheetExists(e) Then
            Sheets(e).Cells.Clear
            If Not IsEmpty(dic(e)) Then dic(e).Copy Sheets(e).Cells(1)
            Sheets(e).Columns.AutoFit
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub GetRows(dic As Object, ByVal myMethod As String, r As Range)
    If IsEmpty(dic(myMethod)) Then
        Set dic(myMethod) = r
    Else
        Set dic(myMethod) = Union(dic(myMethod), r)
    End If
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(txt).Name)
    On Error GoTo 0
End Function

option, please check attachment, press Run button or run code "test" (ALT+F8, select "test", press Run)

I just noticed one more thing with these codes. Is there anyway to keep any sheets that may already exist in the workbook. I have a sheet labeled "Map" that needs to be there but everytime I run these codes it deletes it out. Any way around that?

this line identifies sheets that are not subject for deletion:

If InStr("AccessionMaster", sht.Name) = 0 Then sht.Delete

Change it to:

If InStr("AccessionMasterMap", sht.Name) = 0 Then sht.Delete

Great! Thank you.

[code]
If (ws.Name <> "Accession") * (ws.Name <> "Master") * (ws.Name <> "Map") Then ws.Delete[code]

After using both of these codes i discovered one small problem. They do not create new tabs for "methods" with more than one method tagged onto the patients accession number. For instance, if patient 150938290_G_L_F was the only patient then it would create only one method tab, in this case "G" since it is the first one. Now if the L and F tabs are being made from another patient who has those methods as their first, then it would sort the fore-mentioned patient just fine. In other words, it only makes tabs for methods that are listed first in a string rather than all of the methods. Help would be greatly appreciated.

Not really understandable....

Can you post a small sample with

1) Data that doesn't work as expected.
2) Code that you are currently using.