Macro to Find Names that Appear across 8 Columns in same worksheet

[Ben2125]

I have a worksheet in my excel workbook that contains a column of names, followed by 5 columns of data for each name, followed by another column of names with 5 proceeding columns of data for each name (and so on until 8 "sets" have been established. I want to be able to run a macro that finds the names that appear in every single column, or ones that appear in over half the columns, and create a table with these names in it. Just to be more specific, the columns in my workbook are: Player (A), Stat1 (B), Stat2 (C), Stat3 (D), Stat4 (E), Stat5 (F). The next set of names and accompanying data begin in the next available column (G). I have no clue how to even begin writing this code so any information is much appreciated. Thanks in advance.

 

[Ben2125]

Bump

 

[Leith Ross]

Hello Ben2125,

Do the only players names appear in column "A,G,M,S" etc.?

Will the output be a list of unique player names?

Where will the list be output?

What should the output look like?

 

[Ben2125]

Hello Ben2125,

Do the only players names appear in column "A,G,M,S" etc.?

Will the output be a list of unique player names?

Where will the list be output?

What should the output look like?

1. Yes, those are the only columns with player names in them (the last names are located in column AQ).
2. Yes, there shouldn't be any duplicates in the outputted names. I want the macro to find the names that appear in over half (or even all 8) columns and output those names.
3. The location of the output can be located in column AW, starting in row 1.
4. The output can just be a column/table filled with the names that occur in over half (or even all 8) columns with names in them. It does not need to have any information alongside the common names.

 

[Leith Ross]

Hello Ben2125,

Thanks for the clarification. I wanted to be sure what you wanted.

This macro will list the names without repeats in column "AW" of the ActiveSheet starting in column 1 and going down. This macro uses a Dictionary Object which stores information in what is called key and item pairs. The "key" is a string that uniquely identifies an element. The "item" can be any data type except a user defined type. In this case it is a long integer that reflects the number of times the "key" was found.

Add a new standard VBA Module to your workbook. Copy and paste this code into it. You can run the macro either by calling it from the Macro Dialog, ALT+F8, or by adding a button on the worksheet to call the macro.

Sub ListNames()


    Dim Cell    As Range
    Dim col     As Long
    Dim n       As Long
    Dim Player  As Variant
    Dim RngIn   As Range
    Dim RngOut  As Range
    Dim Uniques As Object
    
        ' First cell of the Output range.
        Set RngOut = ActiveSheet.Range("AW1")
        
        ' Input range is all data on the Activesheet.
        Set RngIn = ActiveSheet.UsedRange
        
            ' Clear the Output column.
            Range(RngOut, Cells(Rows.Count, RngOut.Column).End(xlUp)).ClearContents
            
            ' Exclude headers in row 1 of the data sheet.
            Set RngIn = Intersect(RngIn, RngIn.Offset(1, 0))
        
            ' Create the Dictionary to hold the player's name and times it is found.
            Set Uniques = CreateObject("Scripting.Dictionary")
            
            ' Ignore case when saving player's names.
            Uniques.CompareMOde = vbTextCompare
            
            ' Examine only the columns with names: A, G, M, S etc.
            For col = 1 To RngIn.Columns.Count Step 6
                ' Get the name of each player.
                For Each Cell In RngIn.Columns(col).Cells
                    ' Remove leading and trailing spaces & leave only a single space between words.
                    Player = Application.Trim(Cell)
                    ' Exclude empty cells.
                    If Player <> "" Then
                        ' Check if the Player's name has been added.
                        If Not Uniques.Exists(Player) Then
                            ' Not found so add it with a count of 1.
                            Uniques.Add Player, 1
                        Else
                            ' Found so increment the find count by 1.
                            n = Uniques(Player)
                            Uniques(Player) = n + 1
                        End If
                    End If
                Next Cell
            Next col
            
            ' Output player names that were found 4 or more times.
            For Each Player In Uniques.Keys
                If Uniques(Player) >= 4 Then
                    RngOut = Player
                    Set RngOut = RngOut.Offset(1, 0)
                End If
            Next Player
            
End Sub

 

[Ben2125]

Hello Ben2125,

Thanks for the clarification. I wanted to be sure what you wanted.

This macro will list the names without repeats in column "AW" of the ActiveSheet starting in column 1 and going down. This macro uses a Dictionary Object which stores information in what is called key and item pairs. The "key" is a string that uniquely identifies an element. The "item" can be any data type except a user defined type. In this case it is a long integer that reflects the number of times the "key" was found.

Add a new standard VBA Module to your workbook. Copy and paste this code into it. You can run the macro either by calling it from the Macro Dialog, ALT+F8, or by adding a button on the worksheet to call the macro.

Sub ListNames()


    Dim Cell    As Range
    Dim col     As Long
    Dim n       As Long
    Dim Player  As Variant
    Dim RngIn   As Range
    Dim RngOut  As Range
    Dim Uniques As Object
    
        ' First cell of the Output range.
        Set RngOut = ActiveSheet.Range("AW1")
        
        ' Input range is all data on the Activesheet.
        Set RngIn = ActiveSheet.UsedRange
        
            ' Clear the Output column.
            Range(RngOut, Cells(Rows.Count, RngOut.Column).End(xlUp)).ClearContents
            
            ' Exclude headers in row 1 of the data sheet.
            Set RngIn = Intersect(RngIn, RngIn.Offset(1, 0))
        
            ' Create the Dictionary to hold the player's name and times it is found.
            Set Uniques = CreateObject("Scripting.Dictionary")
            
            ' Ignore case when saving player's names.
            Uniques.CompareMOde = vbTextCompare
            
            ' Examine only the columns with names: A, G, M, S etc.
            For col = 1 To RngIn.Columns.Count Step 6
                ' Get the name of each player.
                For Each Cell In RngIn.Columns(col).Cells
                    ' Remove leading and trailing spaces & leave only a single space between words.
                    Player = Application.Trim(Cell)
                    ' Exclude empty cells.
                    If Player <> "" Then
                        ' Check if the Player's name has been added.
                        If Not Uniques.Exists(Player) Then
                            ' Not found so add it with a count of 1.
                            Uniques.Add Player, 1
                        Else
                            ' Found so increment the find count by 1.
                            n = Uniques(Player)
                            Uniques(Player) = n + 1
                        End If
                    End If
                Next Cell
            Next col
            
            ' Output player names that were found 4 or more times.
            For Each Player In Uniques.Keys
                If Uniques(Player) >= 4 Then
                    RngOut = Player
                    Set RngOut = RngOut.Offset(1, 0)
                End If
            Next Player
            
End Sub

Thank you so much, this worked perfectly.