Guidance on Refactoring a List of Stores Into an Email List

Hi, I'm not an Excel guru, so hoping to get some insight, tips, or guidance on how to approach a fairly complex issue.

We receive a list of stores from a client that we need to turn into a master email list we'll use for doing email marketing. The list we receive is based around single unique Store Numbers for each record (row). But we need to convert this to being based around a single unique Email Address for each record. There are over 1,000 records in the file we receive.

The problem is that each of their records will have multiple staff members with email addresses included (a Main, Sales Manager, and Owner). So these need to be extrapolated into individual records.

BUT, there are also instances where the same email address is used on multiple records (e.g, a store has a few locations with the same staff member). And in these instances where a single staff member (email address) is included on multiple store records, we would still like to know what all Store Numbers they are associated with. So we may need to combine the individual store numbers into a single field, probably comma separated.

And lastly, we would like some sort of indication of what role they have (e.g., Main, Sales, Owner). A simple 'X' in a corresponding column would be fine for this.

To make it more clear here is a VERY simplified version of this. The first sheet (Original) is basically what we receive from the client. The second sheet (Final Result) shows how the first couple records should be refactored (I only did a couple for this).

Sample-Store-List.xlsx

ANY guidance or direction on how to approach this would be most welcomed!

I gave MS Copilot a go at helping come up with a solution and it eventually helped me create the following VBA script. There are a few additional fields I added, and some additional formatting required, from the sample posted here. I'm shocked that it actually seems to be working! I just do not know VBA coding at all to know if it's doing it the RIGHT way or not. Having to check it now on the more complete dataset to see if anything throws it off.

Sub RefactorData()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet
    Dim lastRow As Long
    Dim emailList As Collection
    Dim i As Long, j As Long
    Dim email As String
    Dim newRow As Long
    Dim exists As Boolean

    ' Ensure the sheet "ToRefactor" exists and set the reference
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("ToRefactor")
    If ws Is Nothing Then
        MsgBox "Sheet 'ToRefactor' not found. Please ensure the sheet name is correct.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Ensure the sheet "Refactored" exists and set the reference
    On Error Resume Next
    Set wsOutput = ThisWorkbook.Sheets("Refactored")
    If wsOutput Is Nothing Then
        MsgBox "Sheet 'Refactored' not found. Please ensure the sheet name is correct.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Add headers to the Refactored sheet
    wsOutput.Cells(1, 1).Value = "Store #"
    wsOutput.Cells(1, 2).Value = "Store Name"
    wsOutput.Cells(1, 3).Value = "Name"
    wsOutput.Cells(1, 4).Value = "Email"
    wsOutput.Cells(1, 5).Value = "City"
    wsOutput.Cells(1, 6).Value = "St"
    wsOutput.Cells(1, 7).Value = "Division Name"
    wsOutput.Cells(1, 8).Value = "Main"
    wsOutput.Cells(1, 9).Value = "Sales"
    wsOutput.Cells(1, 10).Value = "Owner"

    ' Initialize email list
    Set emailList = New Collection

    ' Loop through all rows to collect unique emails and combine data
    For i = 2 To lastRow
        Dim emails(1 To 3) As String
        Dim names(1 To 3) As String
        emails(1) = ws.Cells(i, "D").Value ' Main Email
        emails(2) = ws.Cells(i, "F").Value ' Sales Email
        emails(3) = ws.Cells(i, "H").Value ' Owner Email
        names(1) = ws.Cells(i, "C").Value ' Main Name
        names(2) = ws.Cells(i, "E").Value ' Sales Name
        names(3) = ws.Cells(i, "G").Value ' Owner Name

        For j = 1 To 3
            email = emails(j)
            If email <> "" Then
                exists = False

                For Each item In emailList
                    If item(1) = email Then
                        newRow = item(0)
                        exists = True

                        ' Ensure unique store numbers
                        Dim storeArray() As String
                        Dim storeNumber As String
                        storeArray = Split(wsOutput.Cells(newRow, 1).Value, ", ")
                        storeNumber = ws.Cells(i, "A").Value
                        
                        Dim found As Boolean
                        found = False
                        For Each store In storeArray
                            If store = storeNumber Then
                                found = True
                                Exit For
                            End If
                        Next store
                        
                        If Not found Then
                            If wsOutput.Cells(newRow, 1).Value = "" Then
                                wsOutput.Cells(newRow, 1).Value = storeNumber
                            Else
                                wsOutput.Cells(newRow, 1).Value = wsOutput.Cells(newRow, 1).Value & ", " & storeNumber
                            End If
                        End If
                        Exit For
                    End If
                Next item

                If Not exists Then
                    newRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row + 1
                    wsOutput.Cells(newRow, 1).Value = ws.Cells(i, "A").Value
                    wsOutput.Cells(newRow, 2).Value = ws.Cells(i, "B").Value
                    wsOutput.Cells(newRow, 5).Value = ws.Cells(i, "I").Value
                    wsOutput.Cells(newRow, 6).Value = ws.Cells(i, "J").Value
                    wsOutput.Cells(newRow, 7).Value = ws.Cells(i, "K").Value
                    emailList.Add Array(newRow, email)
                End If

                Select Case j
                    Case 1
                        wsOutput.Cells(newRow, 3).Value = names(j)
                        wsOutput.Cells(newRow, 4).Value = email
                        wsOutput.Cells(newRow, 8).Value = "X"
                    Case 2
                        wsOutput.Cells(newRow, 3).Value = names(j)
                        wsOutput.Cells(newRow, 4).Value = email
                        wsOutput.Cells(newRow, 9).Value = "X"
                    Case 3
                        wsOutput.Cells(newRow, 3).Value = names(j)
                        wsOutput.Cells(newRow, 4).Value = email
                        wsOutput.Cells(newRow, 10).Value = "X"
                End Select
            End If
        Next j
    Next i

    MsgBox "Data refactoring complete!"
End Sub