Create sheets based on unique values in rows based on Primary Key

Question

I am trying to populate multiple sheets based on the given data (attached Samplesheet SampleSheet.xlsx) as per the below rules:

1. Customer Code is the primary key, there should be each sheet for each unique customer code.
2. The new sheets should be named as "CustomerCode_Leads"
3. Every worksheet should have same headers.

I have started up with a logic and build a code behind but am lacking the knowledge on how to read the customer code data line by line, copy the rows with the same customer code and paste it in the sheet based on unique customer code.

Code written so far:

Sub Test()
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Data")
    ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
    
    Selection.AutoFilter
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.EntireRow.Select
    Selection.Delete Shift:=xlUp
    Application.Goto Reference:="R2C2"
    ActiveCell.EntireColumn.Select
    
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$5000").RemoveDuplicates Columns:=1, Header:=xlYes
    
    Dim CurSheet As Worksheet
    Dim Source As Range
    Dim c As Range

    Set CurSheet = ActiveSheet
    Set Source = Selection.Cells
    Application.ScreenUpdating = False

    For Each c In Source
        sName = Trim(c.Text)
        If Len(sName) > 0 Then
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sName + "_Leads"
        End If
    Next c
    
End Sub

Output Desired:

Can someone advise how to read the data row by row and paste it in a new worksheet named "CustomerCode_Lead" where "CustomerCode" is a variable with some values in the Data sheet.

The algorithm that I am following is:

1. Copy the datasheet and paste it into a new worksheet

2. Sort the data in ascending order based on Customer Code (it'll bring all the similar customer code together and ease the row by row reading)

3. Read the data row by row and copy the entire row and paste into a new sheet until the customer code stays the same, once different code arrives in the next row, it creates a new sheet named "CustomerCode_Leads"

4. Do the reading of data until the end of the data in the "Data" sheet.

I would absolutely thank you in advance for the help I'll get here from the community. :)

Answer 1

This is all you need:

1. Get all unique values of customer ID column
2. Filter data and copy to another sheet

It could look like below:

Option Explicit

Public Sub SplitDataByCustomerIntoSheets()
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    Dim LastRow As Long
    LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    
    'creat unique list of customer codes (https://stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba)
    Dim UniqueValues() As Variant
    UniqueValues = wsData.Range("A2:A" & LastRow).Value
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim iRow As Long
    For iRow = 1 To UBound(UniqueValues)
        dict(UniqueValues(iRow, 1)) = Empty
    Next
    
    UniqueValues = WorksheetFunction.Transpose(dict.Keys())
    
    
    'check if filter was already set
    If wsData.FilterMode = False Then
        wsData.Range("A1").AutoFilter
    Else
        wsData.ShowAllData
    End If
    
    Dim CustomerID As Variant
    For Each CustomerID In UniqueValues 'loop through all customer IDs
        With wsData.Range("A1:B" & LastRow) 'make sure to adjust B to the last column of your data
            .AutoFilter Field:=1, Criteria1:=CustomerID 'filter by customer ID
            
            'create a new sheet as last sheet and name it by customer ID
            Dim NewSheet As Worksheet
            Set NewSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            NewSheet.Name = CustomerID & "_Leads"
            
            'copy visible cells of filtered data to new sheet
            .SpecialCells(xlCellTypeVisible).Copy NewSheet.Range("A1")
        End With
    Next CustomerID
End Sub

Data sheet:

It will create a sheet for each customer ID like this: