Creating a Client List from Monthly Summary

[jakmc25]

For our business we have an excel sheet we track income on.
Each month has its own sheet then i have a client sheet where i want to make a list of all clients in each month ignoring the duplicates and also trailing spaces and capitalization.

SO basically i need to use VBA to pull First Name (C3:C200) and Last Name (D:3:D200) from all 12 Monthly sheets and put them in the "Client List" sheet in column B3:B1000 (First Name) and C3:C1000 (Last Name) then filter out all duplicates and erase any trailing spaces from names.

Can someone please help me with this project i have been stuck for awhile now.
Thanks!

 

[Leith Ross]

Hello jakmc25,

This worked in my tests. Try this on your workbook, provided the ranges you posted match those of your original workbook.

Add a new VBA Module to to your workbook. Copy and paste the macro into it. You can then run the macro ListClients using the Macro Dialog (keys Alt+F8) or from the VBA Editor.

Option Explicit

Sub ListClients()

    Dim Data    As Variant
    Dim Dict    As Object
    Dim DstRng  As Range
    Dim DstWks  As Worksheet
    Dim Key     As Variant
    Dim Output  As Variant
    Dim r       As Long
    Dim RngEnd  As Range
    Dim SrcRng  As Range
    Dim SrcWks  As Worksheet
   
        Set DstWks = ThisWorkbook.Worksheets("Client List")
       
        Set DstRng = DstWks.Range("B3:C3")
        Set RngEnd = DstWks.Cells(Rows.Count, DstRng.Column).End(xlUp)
       
        If RngEnd.Row >= DstRng.Row Then
            DstRng.Resize(RngEnd.Row - DstRng.Row + 1, 2).ClearContents
        End If

            Set Dict = CreateObject("Scripting.Dictionary")
                Dict.CompareMode = vbTextCompare
               
            For Each SrcWks In ThisWorkbook.Worksheets
                If SrcWks.Name <> DstWks.Name Then
                    Set SrcRng = SrcWks.Range("C3:D3")
                    Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
                    If RngEnd.Row >= SrcRng.Row Then
                        Data = SrcRng.Resize(RngEnd.Row - SrcRng.Row + 1, 2).Value
                        For r = 1 To UBound(Data, 1)
                            ReDim Output(1)
                                Output(0) = Application.Trim(Data(r, 1))
                                Output(1) = Application.Trim(Data(r, 2))
                            Key = Output(0) & Output(1)
                            If Not Dict.Exists(Key) Then
                                Dict.Add Key, Output
                            End If
                        Next r
                    End If
                End If
            Next SrcWks
           
            ReDim Data(Dict.Count - 1, 1)
           
            For r = 0 To Dict.Count - 1
                Data(r, 0) = Dict.Items()(r)(0)
                Data(r, 1) = Dict.Items()(r)(1)
            Next r
           
        DstRng.Resize(UBound(Data, 1) + 1, UBound(Data, 2) + 1).Value = Data
           
End Sub

 

[jakmc25]

So far it seems like that works perfect! thank you so much for the help

 

[Leith Ross]

Hello jakmc25,

You're welcome. If you have any problems with the macro, let me know. Thanks for the feedback.