Help In updating my code, Employee Number Generator

[Sharid]

I have a code that generates employee numbers at random, I have noticed a few errors on it and can not fix them.

1. It changes the whole row to red, when it should only be the employee number that is red.
2. The code only works once, then it will only work if there are blank cells above a cell with a value. E.G. cell A1=value and cell A7=value Cells A2 to A6 are empty then the code will work as these cells are above A7 and empty, so it will place a value into them.

What I need is for it to check Column B and if it has a value then input a value in the cell/s in Column A, and only turn column A to Red.

Please see attached link
Download a demo sheet from this link

 

[davesexcel]

Nope, the code I gave you makes sure it doesn't add a duplicate number.

 

[Sharid]

Sorry Davesexcel

There has probably been a misunderstanding on my behalf. I took this bit of what you said

"I'm not sure how to test this, I know it works when I hard code the employee number. "

I then wanted to test the code for myself and added the duplicate values in Yellow and Blue in column A, I wanted to see if it would find them and replace them with new number, which it did not do.

If you are saying the code will not create duplicates when FIRST used, then, there is no need to look for duplicates as they can not be created.

Is this correct?

 

[davesexcel]

Yes, I might have the r= in the wrong spot it should be in the 2nd loop

Private Sub CommandButton1_Click()
    Dim lastRow As Long
    Dim thisRow As Long, r As String, x

    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    For thisRow = 1 To lastRow
        x = 1
        If Cells(thisRow, "B").Value <> "" And Cells(thisRow, "A") = "" Then
          
            Do Until x = 0
             r = "EmpNo. " & Format$(WorksheetFunction.RandBetween(0, 99999999), "00000000")
                x = Application.WorksheetFunction.CountIf(Range("A:A"), r)
                If x = 0 Then
                    Cells(thisRow, "A").Value = r
                    Cells(thisRow, "A").Font.Color = vbRed
                End If
            Loop
        End If
    Next thisRow
End Sub

 

[Sharid]

Davesexcel

Firstly thanks for the update, Can you confirm the following?

Are you saying that the code WILL NOT create a duplicate? AS

I manually placed 3 duplicates and it did NOT find or REPLACE them, it created new numbers for records that did not have and numbers as shown in red, see image.

If the code CAN NOT create duplicates then there is NO need to look for duplicates.

However, if the codes job is also to LOOK for duplicates and then replace them it is NOT finding them. This is what I just ran.

• Column C is for your REFF. ONLY
• Numbers in Red in Column A are the new employee numbers created.
• Column A has cells in YELLOW AND BLUE these are duplicates as shown in GREEN in column A.

If the code is to find and replace duplicates, then it has not done this and is not working.
If the code does not create duplicates then there is no need to search for duplicates as none will be created.

Could you please clarify

Thank you so much, for what you have done so far.

 

[davesexcel]

The code will not add duplicate numbers, putting duplicate numbers in column A is redundant.
I dragged column B down 40k rows and ran the code, it did not punch out any duplicate numbers.(it took a minute or so to run for 40k rows)

Test it out

Private Sub CommandButton1_Click()
    Dim lastRow As Long
    Dim thisRow As Long, r As String, x

    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    For thisRow = 1 To lastRow
        x = 1
        If Cells(thisRow, "B").Value <> "" And Cells(thisRow, "A") = "" Then

            Do Until x = 0
                r = "EmpNo. " & Format$(WorksheetFunction.RandBetween(0, 99999999), "00000000")
                x = Application.WorksheetFunction.CountIf(Range("A:A"), r)
                If x = 0 Then
                    Cells(thisRow, "A").Value = r
                    Cells(thisRow, "A").Font.Color = vbRed
                End If
            Loop
        End If
    Next thisRow
    countDupes
End Sub
Sub countDupes()
    Dim sh As Worksheet, rng As Range
    Set sh = ActiveSheet
    With sh
        Set rng = .Range("C2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        rng = "=COUNTIF(A:A,A2)"
        rng.Value = rng.Value
        .Range("D2") = "=COUNTIF(C:C,"">1"")"
    End With

End Sub

 

[Sharid]

Super, Thank you very much. I will use this now