Sub SerialNumberResultsAndFrequencies()
Dim R As Long, X As Long, Seed As Long
Dim First As String, Second As String, Third As String, Digit(1 To 3) As String
Dim Data As Variant, Results As Variant
Seed = Range("D1").Value
Data = Range("D2", Cells(Rows.Count, "D").End(xlUp)).Value
ReDim Results(1 To UBound(Data), 1 To 1)
For R = 1 To UBound(Data)
If Len(Data(R, 1)) Then
For X = 1 To Len(Data(R, 1))
If Mid(Data(R, 1), X, 3) Like "[UD]#[COD]" Then
First = Left(Data(R, 1), X) & "1"
Second = Mid(Data(R, 1), X + 1)
Exit For
ElseIf Mid(Data(R, 1), X, 2) Like "##" Then
First = Left(Data(R, 1), X)
Second = Mid(Data(R, 1), X + 1)
Exit For
End If
Next
For X = Len(Second) To 1 Step -1
If Mid(Second, X, 3) Like "[UD]#[COD]" Then
Third = Mid(Second, X + 1)
Second = Left(Second, X) & "1"
ElseIf Mid(Second, X, 2) Like "##" Then
Third = Mid(Second, X + 1)
Second = Left(Second, X)
End If
Next
If Right(Third, 1) Like "[UD]" Then Third = Third & "1"
Digit(Mid(First, 3, 1)) = Mid(Seed, Left(First, 1), 1)
If Mid(First, 2, 1) = "O" Then Digit(Mid(First, 3, 1)) = Right(Digit(Mid(First, 3, 1)) + Right(First, 1) * Choose(2 + (Right(First, 2) Like "D*"), -1, 1), 1)
Digit(Mid(Second, 3, 1)) = Mid(Seed, Left(Second, 1), 1)
If Mid(Second, 2, 1) = "O" Then Digit(Mid(Second, 3, 1)) = Right(Digit(Mid(Second, 3, 1)) + Right(Second, 1) * Choose(2 + (Right(Second, 2) Like "D*"), -1, 1), 1)
Digit(Mid(Third, 3, 1)) = Mid(Seed, Left(Third, 1), 1)
If Mid(Third, 2, 1) = "O" Then Digit(Mid(Third, 3, 1)) = Right(Digit(Mid(Third, 3, 1)) + Right(Third, 1) * Choose(2 + (Right(Third, 2) Like "D*"), -1, 1), 1)
Results(R, 1) = Digit(1) & Digit(2) & Digit(3)
End If
Next
With Range("E2").Resize(UBound(Results))
.NumberFormat = "000"
.Value = Results
End With
With Range("F2").Resize(UBound(Results))
.Formula = "=IF(" & .Offset(, -1).Address & "=0,"""",COUNTIF(" & .Offset(, -1).Address & ",E2))"
.Value = .Value
End With
End Sub
Bookmarks