Create Sheets With Data Based on Field

BrittKnee

Board Regular
Joined
Dec 4, 2017
Messages
82
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.

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

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
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).
 
Upvote 0
Maybe this code can help you

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

Forum statistics

Threads
1,213,549
Messages
6,114,264
Members
448,558
Latest member
aivin

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