Add new sheet using matching numerial prefix

Question

In the below I am trying to create new tabs in a worksheet based of a column 3 in MainSheet (if they dont exist already). I think the below should do that, but I can not figure out how to group lines in MainSheet based on a matching number prefix.... that is 210422-C is the cell and the 2104 once extracted matches the line below it. So those two lines would be copied to a new tab called 04-21 (reverse of the extracted prefix separated with a - after the second digit). 210505-C is the cell and the 2105 once extracted matches the line below it. So those two lines would be copied to a new tab called 05-21 (reverse of the extracted prefix separated with a - after the second digit). There wont always be two rows that match and there are multiple columns in each line. Thank you :).

MainSheet

header row
12  aaaa    210422-C    bbb
12  abaa    210429-C    bbb
12  caaa    210505-C    bbb
12  dddd    210511-C    bbb

Desired

04-21

header row
12  aaaa    210422-C    bbb
12  abaa    210429-C    bbb

05-21

header row
12  caaa    210505-C    bbb
12  dddd    210511-C    bbb

VBA

Private Sub 
CommandButton1_Click() 
Dim MainSheet As Worksheet
Dim NewSheet As Worksheet
Dim myBook As Workbook
Dim lastRow As Long
Dim i As Long
Dim namesColumn

'Define workbook - here set as the active workbook
Set myBook = ActiveWorkbook

'Define worksheets - The sheets are named "MainSbeet"
Set masterSheet =
myBook.Worksheets("MainSheet")

'Define which column in your master tab to search
 namesColumn = 3

'Find the last row of the sheets list
 lastRow = MainSheet.Cells(MainSheet.Rows.Count, namesColumn).End(xlUp).Row

'Cycle through the list - Assuming header row and starts in column "A" from the 2nd row
For i = 2 To lastRow
    With myBook
'Define new sheet
    Set NewSheet = .Worksheets.Add(After:=.Worksheets("MainSheet"))
 End With

'Find name of the tab and naming the tab
tabName = masterSheet.Cells(i, namesColumn)
     NewSheet.Name = tabName

'Copy from MainSheet  MainSheet.ActiveCell.EntireRow.Select.Copy _
      Destination:=NewSheet.ActiveCell.EntireRow.Select

'Paste in e.g. cell A1 i.e. (1,1) the tab name
NewSheet.Cells(1, 1).Value = tabName

'Only add sheet if it doesn't exist already and the name is longer than zero characters
If (Sheet_Exists(NewSheet) = False) And (NewSheet <> "") Then
 Worksheets.Add().Name = NewSheet
End If

Next i
End Sub

Answer 1

It is pretty simple actually once you understand the logic.

LOGIC:

1. Identify your range.
2. Get the range in an array.
3. Loop through the array and extract left 4 characters and create a unique collection. This will also help us identify the number of sheets that needs to be created.
4. Loop through the collection and create the sheets.
5. Copy across the headers from main sheet to the newly created sheet.
6. In the same loop, filter the data from main sheet based on the 4 charcters in the collection and copy across to the newly created sheet. More about this method is explained in How to copy a line in excel using a specific word and pasting to another excel sheet.

CODE:

I have commented the code but if you still face any issues, simply ask :)

Option Explicit

Sub Sample()
    Dim wsThis As Worksheet, wsNew As Worksheet
    Dim rng As Range, rngToCopy As Range
    Dim lRow As Long, i As Long
    Dim Ar As Variant, itm As Variant
    Dim col As New Collection
    Dim shtName As String
    
    '~~> Change this to the relevant sheet
    Set wsThis = Sheet1
    
    With wsThis
        '~~> Remove any filters
        .AutoFilterMode = False
        
        '~~> Find last row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Identify your range
        Set rng = .Range("A1:D" & lRow)
        
        '~~> Get the range in an array
        Ar = rng.Value2
    End With
    
    '~~> Create a unique collection of left 4 characters
    For i = 2 To UBound(Ar)
        On Error Resume Next
        col.Add Left(Trim(Ar(i, 3)), 4), CStr(Left(Trim(Ar(i, 3)), 4))
        On Error GoTo 0
    Next i
    
    '~~> Loop through the collection
    For Each itm In col
        '~~> Sheet name
        shtName = Right(itm, 2) & "-" & Left(itm, 2)

        '~~> Check if the sheets already exist
        On Error Resume Next
        Set wsNew = Nothing
        Set wsNew = ThisWorkbook.Sheets(shtName)
        On Error GoTo 0
        
        '~~> If it doesn't then create it
        If wsNew Is Nothing Then
            '~~> Create the relevant sheet
            ThisWorkbook.Sheets.Add( _
            After:=ThisWorkbook.Sheets( _
                   ThisWorkbook.Sheets.Count) _
                   ).Name = shtName
                    
            Set wsNew = ThisWorkbook.Sheets(shtName)
           
            '~~> Copy headers across
            wsThis.Rows(1).Copy wsNew.Rows(1)
        End If
        
        '~~> Find last row in case there is data from before
        lRow = wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Row + 1
        
        '~~> Fiter the range based on the 4 chars
        With rng
            .AutoFilter Field:=3, Criteria1:="=" & itm & "*"
            Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        wsThis.AutoFilterMode = False
        
        '~~> Copy across relevant range to newly create sheet
        If Not rngToCopy Is Nothing Then
            rngToCopy.Copy wsNew.Rows(lRow)
            Set rngToCopy = Nothing
        End If
    Next itm
End Sub

IN ACTION:

NOTE:

The above code now takes care into valid concerns raised by @chrisneilsen.

1. If there is already a sheet existing with that name then it will use that and not create a new sheet.
2. If the sheet exists and if there is data, then the data is added at the end. I have demonstraded that in the above screenshot. If you want to overwrite the data then simply clear the data from row 2 onwards before finding the last row lRow = wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Row + 1
3. The sheet names were reversed as required.

Answer 2

Looping through the data and testing for the worksheet name is possibly the easiest way.

Private Sub SplitTable() 'CommandButton1_Click()
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets("MainSheet")
    Dim wsLastRow As Long: wsLastRow = wsSrc.Range("A1").CurrentRegion.Rows.count
    Dim i As Long, wsDest As Worksheet, wsName As String
    
    With wsSrc
        For i = 2 To wsLastRow
            wsName = Mid(.Cells(i, 3), 3, 2) & "-" & Left(.Cells(i, 3), 2)
            If Not WorkSheetExists(wsName, ThisWorkbook) Then
                ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)).Name = wsName
                .Rows(1).EntireRow.Copy Destination:=ThisWorkbook.Worksheets(wsName).Rows(1)
            End If
            Set wsDest = ThisWorkbook.Worksheets(wsName)
            .Rows(i).EntireRow.Copy Destination:=wsDest.Rows(wsDest.Range("A1").CurrentRegion.Rows.count + 1)
        Next i
    End With
End Sub

Private Function WorkSheetExists(ByVal SheetName As String, ByRef TargetWorkbook As Workbook) As Boolean
   On Error Resume Next
   WorkSheetExists = Not TargetWorkbook.Worksheets(SheetName) Is Nothing
End Function