Create new worksheet for each unique value - excel

Question

I have the following code that does a great job at copying relevant data into my sheets. I create each sheet manually for every unique department in column J, then I run this macro. I would like a macro that creates the sheets dynamically based on unique values within column J. I have found good resources online but the ones I've found seem to error when it reaches a row that has already had a sheet created for it. I have included the code I'm currently using as well as a screenshot of my inventory sheet before I manually create the other worksheets
Sub CopyRows()
Dim bottomJ As Integer
bottomJ = Range("J" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("All Dept.").Range("J2:J" & bottomJ)
For Each ws In Sheets
ws.Activate
If ws.Name = c Then
c.EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next ws
Next c
End Sub

Answer 1

Try this.
Sub CreateSheets()
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
Set rng = .Range(.Range("J2"), .Range("J" & .Rows.Count).End(xlUp))
End With
For Each cl In rng
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, cl.Value
End If
Next cl
For Each ky In dic.keys
Sheets.Add(After:=Sheets(Sheets.Count)).Name = dic(ky)
Next ky
End Sub

Answer 2

Create Criteria Worksheets
The problem with your idea is e.g. that you use the Hafiz Sb's CreateSheets procedure to create the worksheets and then you use your CopyRows procedure to write the data. Now you add more data to the main worksheet and you're stuck. How will you add the new data to the respective worksheets?
The following assumes that you will only add, not delete data from the main worksheet.
It will copy the main worksheet as many times as there are unique values in a column ('scCol') and by using Autofilter, will delete the undesired data on each of the worksheets (it is my idea, but something similar (if not the same) was suggested by Cyril in the comments).
I did something similar here, which writes the worksheets to separate workbooks.
Option Explicit
Sub CriteriaWorksheetsCreator()
' Accompanying procedures:
' ArrUniqueColumnRange
' DeleteWorksheetsViaArray
Const sName As String = "All Dept."
Const sFirst As String = "A1"
Const sfRow As Long = 1 ' Header Row
Const scCol As Long = 10 ' Criteria Column
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim rg As Range: Set rg = sws.Range(sFirst).CurrentRegion
If rg.Rows.Count = 1 Then Exit Sub ' only one (header) row
If rg.Columns.Count < scCol Then Exit Sub ' too few columns
Dim strg As Range
Set strg = rg.Resize(rg.Rows.Count - sfRow + 1).Offset(sfRow - 1)
Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
Dim scrg As Range: Set scrg = sdrg.Columns(scCol)
Dim wsNames As Variant: wsNames = ArrUniqueColumnRange(scrg)
If IsEmpty(wsNames) Then Exit Sub ' no valid data in 'scrg'
Dim tAddress As String: tAddress = strg.Address
Dim cAddress As String: cAddress = scrg.Address
Application.ScreenUpdating = False
DeleteWorksheetsViaArray wb, wsNames
Dim dws As Worksheet
Dim dtrg As Range
Dim dcrg As Range
Dim drg As Range
Dim n As Long
Dim dName As String
For n = 0 To UBound(wsNames)
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
dName = wsNames(n)
dws.Name = dName
Set dtrg = dws.Range(tAddress)
dtrg.AutoFilter scCol, "<>" & dName
If Application.Subtotal(103, dtrg.Columns(scCol)) > 1 Then
Set dcrg = dws.Range(cAddress)
Set drg = dcrg.SpecialCells(xlCellTypeVisible).EntireRow
drg.Delete
End If
dws.AutoFilterMode = False
Next n
sws.Activate
'wb.Save
Application.ScreenUpdating = True
MsgBox "Criteria worksheets created.", _
vbInformation, "Criteria Worksheets Creator"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values from the first column of a range,
' in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim Data As Variant
Dim rCount As Long
With rg.Columns(1)
rCount = .Rows.Count
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else
Data = .Value
End If
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim r As Long
For r = 1 To rCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next r
If .Count = 0 Then Exit Function ' only error values and/or blanks
ArrUniqueColumnRange = .keys
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Deletes all worksheets whose names are in an array ('wsNames'),
' from a workbook ('wb').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteWorksheetsViaArray( _
ByVal wb As Workbook, _
ByVal wsNames As Variant)
On Error GoTo ClearError
If wb Is Nothing Then Exit Sub
Dim LB As Long: LB = LBound(wsNames)
Dim UB As Long: UB = UBound(wsNames)
Dim wsnCount As Long: wsnCount = UB - LB + 1
Dim DeleteSheetNames() As String: ReDim DeleteSheetNames(0 To wsnCount - 1)
Dim dn As Long
Dim ws As Worksheet
Dim sn As Long
Dim wsName As String
For sn = LB To UB
wsName = wsNames(sn)
On Error Resume Next
Set ws = wb.Worksheets(wsName)
On Error GoTo ClearError
If Not ws Is Nothing Then
If ws.Visible = xlSheetVeryHidden Then
ws.Visible = xlSheetVisible
End If
DeleteSheetNames(dn) = wsName
dn = dn + 1
Set ws = Nothing
End If
Next sn
If dn = 0 Then Exit Sub
If dn < wsnCount Then
ReDim Preserve DeleteSheetNames(0 To dn - 1)
End If
Application.DisplayAlerts = False
wb.Worksheets(DeleteSheetNames).Delete
Application.DisplayAlerts = True
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub