Using macros to create a sheet for each unique value in a list.

E

emily2025

New Member
Joined
May 3, 2017
Messages
1
I have a list of over 500 entries by customer name and I want to be able to create a sheet for each unique customer using macros. Is there a way to do this and to name each sheet based on the customer as well?

I am new to VBA but I tried using two separate strings of code (one to sort through the column, the other to create sheets) but something went wrong along the way.
 
Sort by date Sort by votes
Hi welcome to forum

Assuming that your data has a row with field names ( header row) then give this code a try & see if does what you want:

Place code in a STANDARD module.

Code: 
 Option Explicit

Sub FilterData()
'DMT32 2017
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String
    
    
'master sheet
    Set ws1Master = ActiveSheet
    
'select the Column filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If
    
    FilterCol = objRange.Column
    FilterRow = objRange.Row
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    On Error GoTo progend
    
'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
        
        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
        
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
        
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
                
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
                
'check if sheet exists
                On Error Resume Next
                Set wsNew = Worksheets(SheetName)
                If wsNew Is Nothing Then
'if not, add new sheet
                    Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                Else
'clear existing data
                    wsNew.UsedRange.ClearContents
                End If
                On Error GoTo progend
'apply filter
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNew.Range("A1"), Unique:=False
                
            End If
            wsNew.UsedRange.Columns.AutoFit
            Set wsNew = Nothing
        Next
        
        .Select
    End With
    
    
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

When code is run, you will be presented with an inputbox - using the mouse - select the field name (header) you want to filter & then press OK button.

Code should filter all matching records for each value (customer name) in the column to their own sheet - if sheet does not already exist, code will create it. Data on existing sheets will be cleared & refreshed with each use of the code.

Hope Helpful

Dave
 
Last edited:
Upvote 0
Hi emily2025, Welcome to the Forum. You should always be specific about your columns, rows, sheet names and workbook names. It helps us to write useable code the first time instead of bantering back an forth. Otherwise, we have to make a lot of assumtions to formulate the code. Here is some code based on the assumption that your list is in column A beginning on row 2. we will assume row 1 is a header row.
Code: 
Sub addSheets()
Dim c As Range, sh As Worksheet
With ActiveSheet
    For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
        Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
        sh.Name = c.Value
        Set sh = Nothing
    Next
End With
End Sub
Copy this code to your standard code module 1. Be sure you workbook is saved as a macro enabled workbook.
 
  • Like
Reactions: Aoh
Upvote 0
dmt32 said:
Hi welcome to forum

Assuming that your data has a row with field names ( header row) then give this code a try & see if does what you want:

Place code in a STANDARD module.

Code: 
 Option Explicit

Sub FilterData()
'DMT32 2017
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String
   
   
'master sheet
    Set ws1Master = ActiveSheet
   
'select the Column filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If
   
    FilterCol = objRange.Column
    FilterRow = objRange.Row
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    On Error GoTo progend
   
'add filter sheet
    Set wsFilter = Sheets.Add
   
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
       
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
       
        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
       
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
       
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
       
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
       
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
       
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
           
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
               
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
               
'check if sheet exists
                On Error Resume Next
                Set wsNew = Worksheets(SheetName)
                If wsNew Is Nothing Then
'if not, add new sheet
                    Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                Else
'clear existing data
                    wsNew.UsedRange.ClearContents
                End If
                On Error GoTo progend
'apply filter
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNew.Range("A1"), Unique:=False
               
            End If
            wsNew.UsedRange.Columns.AutoFit
            Set wsNew = Nothing
        Next
       
        .Select
    End With
   
   
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
   
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

When code is run, you will be presented with an inputbox - using the mouse - select the field name (header) you want to filter & then press OK button.

Code should filter all matching records for each value (customer name) in the column to their own sheet - if sheet does not already exist, code will create it. Data on existing sheets will be cleared & refreshed with each use of the code.

Hope Helpful

Dave
Click to expand...
Hi Dave,

You have created a great query here, but I am running into a problem with my specific version and I am wondering if you are able to assist.

I have columns A:AH, but the data that I am filtering on is in column A. I have made the necessary changes below, but have run into a problem.

VBA Code: 
Option Explicit
' Credit: DHM32

Sub FilterDataPlacement()
'switch to general
   Windows("data.xlsm").Activate
  
'paste as values
    Columns("B:B").Select
    Selection.Replace What:="/", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

'begin sub
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String
    Dim location As String
    
    
'master sheet
    Set ws1Master = ActiveSheet
    
'select the Column filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If
    
    FilterCol = objRange.Column
    FilterRow = objRange.Row
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    On Error GoTo progend
    
'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
        
        If FilterCol > colcount Then
            Err.Raise 700000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
        
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
        
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
                
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
                
'check if sheet exists
                On Error Resume Next
                Set wsNew = Worksheets(SheetName)
                If wsNew Is Nothing Then
'if not, add new sheet
                    Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                Else
'clear existing data
                wsNew.UsedRange.ClearContents

                End If
                On Error GoTo progend
'apply filter

                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNew.Range("A1"), Unique:=False
                
            End If
            wsNew.UsedRange.Columns.AutoFit
            Set wsNew = Nothing
        Next
        
        .Select
    End With
    
    
progend:
'    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With

End Sub

When I execute, It is returning some values and not others. In the below mini-table, this is the way my data is structured. The macro will return all matching data for columns A:C, along with all headers. However, for columns D:AV, only rows such as Licensee X will return (when there is a value in column D), and NOT all rows.

1662504824025.png


Are you able to assist with this request for help?
 
Upvote 0
Allow me to change the credit source to "DMT32" from "DHM32" - apologies for the name mistake.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Excel VBA count unique values in a column within a named range
Replies
6
Views
266
Peter_SSs
Peter_SSs
B
  • Solved
Creating Unique list from Customer Order Amount, Customer Name and Order Identifier using the Unique function
2
Replies
11
Views
491
etaf
etaf
D
  • Question Question
Data Validation List without duplicates
2 3 4
Replies
30
Views
1K
kvsrinivasamurthy
K
A
  • Solved
Creating A List of Unique Values
Replies
5
Views
205
mumps
mumps
R
  • Question Question
Could I ask for VBA (or python) code to create a new workbooks?
Replies
2
Views
158
Radoslaw Poprawski
R

Share this page

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