I'm trying to hack the creation of a unique id together, any help appreciated.

[mdutton27]

I need to create a unique ID for tracking stuff and I've used the following to do it for now, but it's not ideal as I need to scale this ability to others as well.
Current solution:
1) Open spreadsheet, insert a new column and find First Name(E2) and Last Name(D2) fields and adjust the following formula to match:

=YEAR(NOW())&"-"&(LEFT(E2,1)&(LEFT(D2,1)&(RANDBETWEEN(10000,10000000000)&"-"&TODAY()-DATE(YEAR(NOW()),1,1)+1)))

2) I then copy the column, insert a new column at A and then Paste/Special/Values so that the Rand doesn't change
3) Delete the original new column and I have static unique id's.

I've been trying to automate this with a macro, but I'm failing miserably as this is as far as I've gotten and I've probably lost 10 - 15 hours of my life, so any help would be appreciated.

Sub Method2()

Sheets.Select
    Dim LastName As Range
    Dim FirstName As Range
   
    Dim FName As String
    Dim FColumn As Long
    Dim LName As String
    Dim LColumn As Long
   
      FName = "First Name"
      LName = "Last Name"
   
Set FirstName = Range("A:Z").Find(FName, , xlValues, xlWhole, xlByColumns)
            FColumn = ActiveCell.Column
            Cells(1, 1) = FColumn
Set LastName = Range("A:Z").Find(LName, , xlValues, xlWhole, xlByColumns)
            LColumn = ActiveCell.Column
            Cells(2, 1) = LColumn

 

[offthelip]

Your requirements are not quite clear but hopefully this will get your started:

Dim outarr()
lastrow = Cells(Rows.Count, "D").End(xlUp).Row
inarr = Range(Cells(1, 4), Cells(lastrow, 5))
ReDim outarr(1 To lastrow, 1 To 1)

nw = Date
yer = Year(nw)
jan1 = DateSerial(yer, 1, 1)
dayno = nw - jan1 + 1
ubnd = 10000000000#
lbnd = 10000

For i = 2 To lastrow
    fn = Left(inarr(i, 2), 1)
    Ln = Left(inarr(i, 1), 1)
    
    rndno = Int((ubnd - lbnd + 1) * Rnd + lbnd)
    outarr(i, 1) = yer & "-" & fn & Ln & rndno & "-" & dayno
Next i
Columns("A:A").Insert Shift:=xlToRight
Range(Cells(1, 1), Cells(lastrow, 1)) = outarr

End Sub

 

[mdutton27]

This is so close to what I need and really appreciate it as I'm learning quite a bit through everyone here on MrExcel.

If possible could you help me address one challenge I'm having with the code you provided. At present it's using column "D". Is there a way for it to find the column with the header text "First Name" and use that column as it may change between sheets?

Again appreciate your help, that's way more elegant that I would ever have come up with!

 

[mdutton27]

Your requirements are not quite clear but hopefully this will get your started:

Dim outarr()
lastrow = Cells(Rows.Count, "D").End(xlUp).Row
inarr = Range(Cells(1, 4), Cells(lastrow, 5))
ReDim outarr(1 To lastrow, 1 To 1)

nw = Date
yer = Year(nw)
jan1 = DateSerial(yer, 1, 1)
dayno = nw - jan1 + 1
ubnd = 10000000000#
lbnd = 10000

For i = 2 To lastrow
    fn = Left(inarr(i, 2), 1)
    Ln = Left(inarr(i, 1), 1)
   
    rndno = Int((ubnd - lbnd + 1) * Rnd + lbnd)
    outarr(i, 1) = yer & "-" & fn & Ln & rndno & "-" & dayno
Next i
Columns("A:A").Insert Shift:=xlToRight
Range(Cells(1, 1), Cells(lastrow, 1)) = outarr

End Sub

This is so close to what I need and really appreciate it as I'm learning quite a bit through everyone here on MrExcel.

If possible could you help me address one challenge I'm having with the code you provided. At present it's using column "D". Is there a way for it to find the column with the header text "First Name" and use that column as it may change between sheets?

Again appreciate your help, that's way more elegant that I would ever have come up with!

 

[offthelip]

try this ( untested) :

Sub test2()

Dim outarr()
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
heads = Range(Cells(1, 1), Cells(1, lastcol))
For j = 1 To lastcol
 If heads(1, j) = "First Name" Then
  Exit For
 End If
Next j

lastrow = Cells(Rows.Count, j).End(xlUp).Row
inarr = Range(Cells(1, j), Cells(lastrow, j + 1))
ReDim outarr(1 To lastrow, 1 To 1)

nw = Date
yer = Year(nw)
jan1 = DateSerial(yer, 1, 1)
dayno = nw - jan1 + 1
ubnd = 10000000000#
lbnd = 10000

For i = 2 To lastrow
    fn = Left(inarr(i, 2), 1)
    Ln = Left(inarr(i, 1), 1)
    
    rndno = Int((ubnd - lbnd + 1) * Rnd + lbnd)
    outarr(i, 1) = yer & "-" & fn & Ln & rndno & "-" & dayno
Next i
Columns("A:A").Insert Shift:=xlToRight
Range(Cells(1, 1), Cells(lastrow, 1)) = outarr

End Sub

 

[mdutton27]

try this ( untested) :

Sub test2()

Dim outarr()
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
heads = Range(Cells(1, 1), Cells(1, lastcol))
For j = 1 To lastcol
If heads(1, j) = "First Name" Then
  Exit For
End If
Next j

lastrow = Cells(Rows.Count, j).End(xlUp).Row
inarr = Range(Cells(1, j), Cells(lastrow, j + 1))
ReDim outarr(1 To lastrow, 1 To 1)

nw = Date
yer = Year(nw)
jan1 = DateSerial(yer, 1, 1)
dayno = nw - jan1 + 1
ubnd = 10000000000#
lbnd = 10000

For i = 2 To lastrow
    fn = Left(inarr(i, 2), 1)
    Ln = Left(inarr(i, 1), 1)
   
    rndno = Int((ubnd - lbnd + 1) * Rnd + lbnd)
    outarr(i, 1) = yer & "-" & fn & Ln & rndno & "-" & dayno
Next i
Columns("A:A").Insert Shift:=xlToRight
Range(Cells(1, 1), Cells(lastrow, 1)) = outarr

End Sub

Just wanted to say Thank You. I know you have helped me and many others on here and those who leverage your knowledge via google searches. I'll do my best to pay it forwards!