Copy row data into new worksheet named as a cell value

LabLady11

New Member
Joined
Oct 22, 2021
Messages
26
Office Version
  1. 2016
Platform
  1. Windows
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!! :)

1684931432183.png
 

Attachments

  • 1684931290519.png
    1684931290519.png
    40.7 KB · Views: 9

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Try this,

VBA Code:
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
 
Upvote 0
Solution
Try this,

VBA Code:
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,

VBA Code:
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!!!
 
Upvote 0

Forum statistics

Threads
1,224,587
Messages
6,179,733
Members
452,939
Latest member
WCrawford

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top