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]

Check it out.

Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim thisRow As Long

lastRow = Cells(Rows.Count, "B").End(xlUp).Row
For thisRow = 1 To lastRow
    If Cells(thisRow, "B").Value <> "" Then
        Cells(thisRow, "A").Value = "EmpNo. " & Format$(WorksheetFunction.RandBetween(0, 99999999), "00000000")
        Cells(thisRow, "A").Font.Color = vbRed
    End If
Next thisRow
End Sub

 

[Sharid]

Davesexcel

This is good but has 1 error,

If I add new records, then when i click the command button, it randomly changes ALL of the employee number, when it should only add to the new records and NOT change the already allocated numbers,

I have attached a picture for your viewing.

1. The numbers in blue where were generated the first time i ran the code, they were in column A, they went up to row 19. i copied them to column C for YOUR viewing.
2. I then added a few more records thinking it would add EmpNo. for the new records but it changed all of the numbers, these are shown in Red.

As you can see the red and blue numbers are different, when they should be the same and ONLY new numbers added to the records 20,21,22.

Hope this helps and thanks for having a look.

 

[davesexcel]

We can see if Column B is not blank and if column A is blank.

Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim thisRow As Long

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

 

[Sharid]

super, this has done the job

thanks

 

[davesexcel]

Just an observation, there is a chance that you will end up with duplicate employee numbers

 

[Sharid]

Is there a work around to this as, it is VERY important that this does not happen, as when employee data is linked, it will use the EmpNo. to ID and link the data. If tow employees have the same number data can get mixed up. This can link wrong wages, performance, expenses and so on.

 

[Sharid]

Is it possible for the code to check for duplicates, every time it has allocated a number, then remove that duplicate EmpNo. and issue a new one, so it loops until no duplicates have been found?

 

[davesexcel]

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

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
            r = "EmpNo. " & Format$(WorksheetFunction.RandBetween(0, 99999999), "00000000")
            Do Until x = 0
                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 having a look.

I have tested your code but it does not seem to change the duplicates, I know you have stated that when you tested it it worked. I don't get the same results as the image shows, see attached.

Column C has the Original EmpNo, for your ref only
Column B has Employees
Column A has the EmpNo.

In column A
Grey cells are when the number first shows
Yellow and blue cells are when the show as duplicate

As you can see from column C nothing has changed, numbers in yellow and blue in column A should have changed, when the code was run again.

I tried to use this, this your second code that you gave, that was much shorter.

   Columns(1).RemoveDuplicates Columns:=Array(1)

But it did not work, as it moved EXISTING numbers up and into the cells that had just been deleted, rather than clearing them and inputting new numbers.

Hope this helps