VBA条件随机序列号生成器不返回唯一值

Question

I'm trying to generate unique random serial number and insert it in each cell in column "A" based on condition that I have a value in corresponding cell in column "E", I'm also using first letter from column “E” in the finished serial number. . However I get repeated values eg SYJ3068 SYJ3068 SNF9678 SNF9678 SNF9678 SGZ5605 SGZ5605 SGZ5605

I've search for solution but without success, could you please point me in the right direction, and help me fix my code so each cell gets unique serial number. With my very limited knowledge of VBA I managed to come up with this:

Sub SumIt()
Dim rRandom_Number As Long
Dim rRandom_1st_Letter As String
Dim rRandom_2nd_Letter As String
Dim rRandom_Serial As String 
Dim CellValue As String
Dim rCell_New_Value As String
Dim RowCrnt As Integer
Dim RowMax As Integer
Dim rCell As Range

With Sheets("Sheet1")

RowMax = .Cells(Rows.Count, "E").End(xlUp).Row
  For RowCrnt = 6 To RowMax
  CellValue = .Cells(RowCrnt, 5).Value
   If Left(CellValue, 1) <> "" Then
   For Each rCell In Range("A6:A" & RowMax)
     Rnd -1
     Randomize (Timer)
     rRandom_Number = Int((9999 + 1 - 1000) * Rnd() + 1000)
     rRandom_1st_Letter = Chr(CInt(Int((90 - 65 + 1) * Rnd() + 65)))
     rRandom_2nd_Letter = Chr(CInt(Int((90 - 65 + 1) * Rnd() + 65)))
     rRandom_Serial = _
     rRandom_1st_Letter _
     & rRandom_2nd_Letter _
     & rRandom_Number
     rCell_New_Value = UCase(Left(Trim(CellValue), 1) & rRandom_Serial)
    .Cells(RowCrnt, 1).Value = rCell_New_Value
  Next
 End If
 Next
End With
End Sub

Many thanks for all your help.

Answer 1

Move Randomize(Timer) outside of your for loop. It only needs to be initialized once.

Answer 2

You can use these encryption functions to generate unique strings based off of two string inputs.

Public Function XORDecryption(CodeKey As String, DataIn As String) As String

    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer


    For lonDataPtr = 1 To (Len(DataIn) / 2)
        'The first value to be XOr-ed comes from the data to be encrypted
        intXOrValue1 = Val("&H" & (Mid$(DataIn, (2 * lonDataPtr) - 1, 2)))
        'The second value comes from the code key
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), 1))

        strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2)
    Next lonDataPtr
   XORDecryption = strDataOut
End Function

Public Function XOREncryption(CodeKey As String, DataIn As String) As String

    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim temp As Integer
    Dim tempstring As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer


    For lonDataPtr = 1 To Len(DataIn)
        'The first value to be XOr-ed comes from the data to be encrypted
        intXOrValue1 = Asc(Mid$(DataIn, lonDataPtr, 1))
        'The second value comes from the code key
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), 1))

        temp = (intXOrValue1 Xor intXOrValue2)
        tempstring = Hex(temp)
        If Len(tempstring) = 1 Then tempstring = "0" & tempstring

        strDataOut = strDataOut + tempstring
    Next lonDataPtr
   XOREncryption = strDataOut
End Function