Copy row data into new worksheet named as a cell value

[LabLady11]

Hello,

I am trying to copy row data from 'Sheet1" into a new worksheet that is named as a value included in Column B on Sheet1.

Sheet1 is below.
I would like to copy row data using the site ID in column B. there are worksheets for each value in column B and there can be 100+ different values/ worksheets for values in Column B.

Ideally the code would sort through values in Column B, Create a worksheet for each unique value and copy the row data into the new worksheet.

this may be a tall ask, but thanks in advance!!

 

[davesexcel]

Try this,

Sub UsingColection()
    Dim cUnique     As Collection
    Dim rng         As Range, cRng As Range
    Dim Cell        As Range, LstRow As Long
    Dim sh          As Worksheet, WS As Worksheet
    Dim vNum        As Variant, s As String
    Dim worksheetexists As Boolean
    Set sh = ThisWorkbook.Sheets("Sheet1")        'data sheet
    Set rng = sh.Range("B2:B" & sh.Cells(sh.Rows.Count, "B").End(xlUp).Row)
    Set cUnique = New Collection
    Application.DisplayAlerts = FALSE
    For Each WS In Sheets
        If WS.Name <> sh.Name Then WS.Delete
    Next
    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    
    For Each vNum In cUnique
        s = vNum
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = vNum
        With sh
            LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A1").AutoFilter Field:=2, Criteria1:=vNum
            Set cRng = .Range("A1:F" & LstRow)
            cRng.Copy Sheets(s).Range("A1")
            .Select
            .Range("A1").AutoFilter
        End With
    Next vNum
    
End Sub

 

[LabLady11]

Try this,

Sub UsingColection()
    Dim cUnique     As Collection
    Dim rng         As Range, cRng As Range
    Dim Cell        As Range, LstRow As Long
    Dim sh          As Worksheet, WS As Worksheet
    Dim vNum        As Variant, s As String
    Dim worksheetexists As Boolean
    Set sh = ThisWorkbook.Sheets("Sheet1")        'data sheet
    Set rng = sh.Range("B2:B" & sh.Cells(sh.Rows.Count, "B").End(xlUp).Row)
    Set cUnique = New Collection
    Application.DisplayAlerts = FALSE
    For Each WS In Sheets
        If WS.Name <> sh.Name Then WS.Delete
    Next
    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
   
    For Each vNum In cUnique
        s = vNum
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = vNum
        With sh
            LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A1").AutoFilter Field:=2, Criteria1:=vNum
            Set cRng = .Range("A1:F" & LstRow)
            cRng.Copy Sheets(s).Range("A1")
            .Select
            .Range("A1").AutoFilter
        End With
    Next vNum
   
End Sub

Try this,

Sub UsingColection()
    Dim cUnique     As Collection
    Dim rng         As Range, cRng As Range
    Dim Cell        As Range, LstRow As Long
    Dim sh          As Worksheet, WS As Worksheet
    Dim vNum        As Variant, s As String
    Dim worksheetexists As Boolean
    Set sh = ThisWorkbook.Sheets("Sheet1")        'data sheet
    Set rng = sh.Range("B2:B" & sh.Cells(sh.Rows.Count, "B").End(xlUp).Row)
    Set cUnique = New Collection
    Application.DisplayAlerts = FALSE
    For Each WS In Sheets
        If WS.Name <> sh.Name Then WS.Delete
    Next
    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
   
    For Each vNum In cUnique
        s = vNum
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = vNum
        With sh
            LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A1").AutoFilter Field:=2, Criteria1:=vNum
            Set cRng = .Range("A1:F" & LstRow)
            cRng.Copy Sheets(s).Range("A1")
            .Select
            .Range("A1").AutoFilter
        End With
    Next vNum
   
End Sub

AMAZING - THANK YOU SO MUCH!!!