Create Sheets With Data Based on Field

[BrittKnee]

Hi! I am creating a macro that will create separate sheets for each department in my company based on a range in a sheet with all source data. This works fine. It creates a sheet for each department in the selected range, but what I really need is to have all the records for that department also in the respective sheet. I have over 50 departments, so doing this manually is way too time consuming. Below is the current macro that I am using to create the sheets. Any and all help is appreciated.

Option Explicit

Sub Create_Dept_ws()

Dim rng As Range
Dim cell As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
'Enable error handling
On Error GoTo Errorhandling
 
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", Title:="Create sheets", Default:=Selection.Address, Type:=8)
 
'Iterate through cells in selected cell range
For Each cell In rng
 
    'Check if cell is not empty
    If cell <> "" Then
        'Insert worksheet and name the worksheet based on cell value
        Sheets.Add.Name = "EEs - " & cell
    End If
Next cell

'Go here if an error occurs
Errorhandling:

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[mumps]

When you select the range, are you selecting the column in which you have the department names? If so, which column contains those names? Can the selected range have multiple occurrences of a particular department? It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Flaiban]

Maybe this code can help you

Sub create_worksheets()
  Dim sh As Worksheet
  Dim vcol As Long, vrow As Long
  Dim title As String, cad As String
  Dim c As Range, xTRg As Range, xVRg As Range
  Dim ky As Variant
  
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  
  On Error Resume Next
    Set xTRg = Application.InputBox("Select header", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Select the column on which you want to split the data in sheets", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Cells(1).Column
    vrow = xTRg.Cells(1).Row
    title = xTRg.AddressLocal
  On Error GoTo 0
  cad = title & "," & xVRg.Address
  Range(cad).Select
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(sh.Cells(vrow + 1, vcol), sh.Cells(Rows.Count, vcol).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range(title).AutoFilter vcol, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Copy Range("A" & vrow)
      ActiveSheet.Columns.AutoFit
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub