Replace all names with random names

Not tested.

Sub DummyMgmtNames()
'Replace Mgmt names with Dummy names
    Dim av1 As Variant
    Dim av2 As Variant
    Dim I As Long
    Dim Idx As Long
    Dim Idx2 As Long

    av1 = Array("Annie D.", "Curtis M.", "Danny C.", "Debbie E.", "Gomer G.", "Sally M.")
    av2 = Array("Minnie", "Mickey", "Donald", "Goofy", "Daffy", "Daisy")

    With Selection
        For I = 0 To Selection.Rows
            Idx = Idx + 1
            .Replace What:=av1(Idx), Replacement:=av2(Idx) & Idx2, _
                                             LookAt:=xlPart, _
                                             MatchCase:=False, _
                                             SearchFormat:=False, ReplaceFormat:=False
            If Idx = UBound(av1) Then
                Idx = 0
                Idx2 = Idx2 + 1
            End If
        Next I
    End With
End Sub

What I do is go to a random name generator (there are numerous ones on the web) and pull 100 randoms first names, then 100 random last names and stick them in a spreadsheet. Then I concatenate the First/Last into Column C. Then I have a ready supply of random names.

David,

I got a "type mismatch" on "For I = 0 To Selection.Rows"

UPDATE: I corrected it by adding ".Count" after ".Rows". Now the macro runs, but I get no results (no changes).

I also have a random name generator, which I could use to copy/paste over my column. But there are blanks in my columns, and I'd want to leave them blank. As well, I'd like some consistency in my column; if "Roger Ebert" exists 20 times in my column, I'd like whatever name replaces him in the first place to be the replacement in all the rest.

jomili,

Assuming the selection only contains names you want to replace, give this a try:

Sub DummyMgmtNames()
'Replace Mgmt names with Dummy names
    
    Dim rngCell As Range
    Dim colNames As Collection
    Dim i As Long
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Set colNames = New Collection
    
    On Error Resume Next
    For Each rngCell In Selection.Cells
        If Not IsNumeric(rngCell.Value) And Len(Trim(rngCell.Value)) > 0 Then
            colNames.Add rngCell.Value, rngCell.Value
        End If
    Next rngCell
    On Error GoTo 0
    
    With Selection
        For i = 1 To colNames.Count
            .Replace colNames(i), "Name" & i
        Next i
    End With
    
    Set colNames = Nothing
    
End Sub

jomili,

Create a workbook to contain the fake names. That workbook should only have 1 sheet, and the fake names should start in A1 and go down column A with no blanks. Then use this code and update the strDummyNameFilePath to the correct file path and file name. I tested it on 48000 rows of names, and it completed in just over 41 seconds:

Sub DummyMgmtNames()
'Replace Mgmt names with Dummy names
    
    'Change this path to the correct path and file name, make sure to update the .xls to correct extension
    Const strDummyNameFilePath As String = "C:\Test\Dummy Names.xls"
    
    Dim rngSel As Range
    Dim grp As Range
    Dim lCalc As XlCalculation
    Dim arrRealNames As Variant
    Dim arrFakeNames As Variant
    Dim i As Long
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set rngSel = Selection
    
    With Workbooks.Open(strDummyNameFilePath)
        arrFakeNames = .Sheets(1).UsedRange.Value
        .Close False
    End With
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    On Error GoTo CleanExit
    
    With Sheets.Add
        For Each grp In rngSel.Areas
            For i = 1 To grp.Columns.Count
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(grp.Rows.Count).Value = grp.Offset(, i - 1).Resize(, 1).Value
            Next i
        Next grp
        .Range("A1").Value = "Names List"
        .Range("A1").Font.Bold = True
        .UsedRange.AdvancedFilter xlFilterCopy, , .Range("B1"), True
        arrRealNames = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).Value
        .Delete
    End With
    
    With rngSel
        If IsArray(arrRealNames) Then
            For i = LBound(arrRealNames, 1) To UBound(arrRealNames, 1)
                If Not IsNumeric(arrRealNames(i, 1)) And Len(Trim(arrRealNames(i, 1))) > 0 Then
                    .Replace arrRealNames(i, 1), arrFakeNames(i, 1), xlWhole
                End If
            Next i
        Else
            If Not IsNumeric(arrRealNames) And Len(Trim(arrRealNames)) > 0 Then
                .Replace arrRealNames, arrFakeNames(1, 1), xlWhole
            End If
        End If
    End With
    
CleanExit:
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    If Err Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    Set rngSel = Nothing
    Set grp = Nothing
    Erase arrFakeNames
    If IsArray(arrRealNames) Then Erase arrRealNames
    
End Sub

Oh, I forgot about that part, give a me a sec to update it so it will reuse the list

---------- Post added at 10:46 AM ---------- Previous post was at 10:41 AM ----------

Updated code:

Sub DummyMgmtNames()
'Replace Mgmt names with Dummy names
    
    'Change this path to the correct path and file name, make sure to update the .xls to correct extension
    Const strDummyNameFilePath As String = "C:\Test\Dummy Names.xls"
    
    Dim rngSel As Range
    Dim grp As Range
    Dim lCalc As XlCalculation
    Dim arrRealNames As Variant
    Dim arrFakeNames As Variant
    Dim NameIndex As Long
    Dim lSuffix As Long
    Dim i As Long
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set rngSel = Selection
    
    With Workbooks.Open(strDummyNameFilePath)
        arrFakeNames = .Sheets(1).UsedRange.Value
        .Close False
    End With
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    On Error GoTo CleanExit
    
    With Sheets.Add
        For Each grp In rngSel.Areas
            For i = 1 To grp.Columns.Count
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(grp.Rows.Count).Value = grp.Offset(, i - 1).Resize(, 1).Value
            Next i
        Next grp
        .Range("A1").Value = "Names List"
        .Range("A1").Font.Bold = True
        .UsedRange.AdvancedFilter xlFilterCopy, , .Range("B1"), True
        arrRealNames = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).Value
        .Delete
    End With
    
    lSuffix = 0
    With rngSel
        If IsArray(arrRealNames) Then
            For i = LBound(arrRealNames, 1) To UBound(arrRealNames, 1)
                If Not IsNumeric(arrRealNames(i, 1)) And Len(Trim(arrRealNames(i, 1))) > 0 Then
                    NameIndex = NameIndex + 1
                    If NameIndex > UBound(arrFakeNames, 1) Then
                        NameIndex = 1
                        lSuffix = lSuffix + 1
                    End If
                    If lSuffix > 0 Then
                        .Replace arrRealNames(i, 1), arrFakeNames(NameIndex, 1) & lSuffix, xlWhole
                    Else
                        .Replace arrRealNames(i, 1), arrFakeNames(NameIndex, 1), xlWhole
                    End If
                End If
            Next i
        Else
            If Not IsNumeric(arrRealNames) And Len(Trim(arrRealNames)) > 0 Then
                .Replace arrRealNames, arrFakeNames(1, 1), xlWhole
            End If
        End If
    End With
    
CleanExit:
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    If Err Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    Set rngSel = Nothing
    Set grp = Nothing
    Erase arrFakeNames
    If IsArray(arrRealNames) Then Erase arrRealNames
    
End Sub

You're very welcome