Find matching data in column, paste to new created worksheet/tab

[marcosis123]

Hi,

I have a table of data and in column C there are multiple entries of the same data.

I would like a macro to copy the rows containing matching values in C to a new sheet named the value of the data.

So if i had 6 rows that said aa,aa,bb,bb,cc,cc in column C id now have three tabs called aa, bb and cc with the 2 matching rows from the main table in each one.

Cheers

 

[QuietRiot]

Sub Copy2NewSheets()
    Dim wsAll As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim LastRow As Long
    Dim LastRowCrit As Long
    Dim k As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Change to main sheet name
    Set wsAll = Worksheets("Sheet1")
    ' Last row of column C
    LastRow = wsAll.Range("C" & Rows.Count).End(xlUp).Row
        
    ' Create a Temp sheet
    Set wsCrit = Worksheets.Add
        
    ' Column C has the criteria
    wsAll.Range("C1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    ' Last row of column A on temp sheet
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    
    For k = 2 To LastRowCrit
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
            CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
    Next
        
    ' Delete Temp sheet
    wsCrit.Delete
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

 

[marcosis123]

Perfect, thank you!

 

[mumps]

Another alternative:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim Rng As Range, WS As Worksheet, key As Variant
    Set WS = ThisWorkbook.Sheets("Sheet1")
    If WS.AutoFilterMode Then WS.AutoFilterMode = False
    With CreateObject("Scripting.Dictionary")
        For Each Rng In WS.Range("C2", WS.Range("C" & WS.Rows.Count).End(xlUp))
            .Item(Rng.Value) = Empty
        Next
        For Each key In .Keys
            With WS
                .Cells(1, 1).CurrentRegion.AutoFilter 3, key
                WS.AutoFilter.Range.Copy
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
                ActiveSheet.Cells(1, 1).PasteSpecial
            End With
        Next key
    End With
    WS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub