Generate serial numbers

[amaresh achar]

Hello, I need a VBA code to generate serial numbers as described in the below image (link)

Can somebody please help me with this...?? Thank you very much in advance...!

http://drive.google.com/file/d/1pFIU3cghghJAuYApKUtx1kYFcD1Ec7bb/view?usp=sharing

 

[amaresh achar]

Yes.. but it is giving out some errors with locked input sheet.. I can't send you the file from my office... Is there any other way than Google drive..!?

 

[MickG]

Try amending the top of code as below:-

With Sheets("Input Sheet")
    .Unprotect Password:="mick"
    Set Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
End With

And place this at the end of the code

Sheets("Input Sheet").Protect Password:="mick"

If you want to send the file try "Box.net" or "DropBox"

 

[amaresh achar]

Hi Mick, Here is the link to my actual file... problem is explained in "Check Sheet" and the password to unrpotect the "Input Sheet" is ABCD1234

https://drive.google.com/file/d/1BPybvB-6LpD5W_SiigEq33KgEcq8dDNy/view?usp=sharing

 

[MickG]

Try this for results on sheet "Check Sheet".

Sub Check_sheet()
Dim Rng As Range, Dn As Range, nRng As Range, R As Range, Rr As Range
Dim RwMax As Long, Rw As Long, Ac As Long, n As Long
With Sheets("Input Sheet")
    .Unprotect Password:="ABCD1234"
    Set Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
End With
Sheets("Check Sheet").Range("C7:M67").ClearContents

For Each Dn In Rng
If Not Dn.Value = "VARIANT" Then
    If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
End If
Next Dn
Rw = 1
For Each Rr In nRng.Areas
RwMax = Application.Max(Rr.Offset(, 1).Value) + 1
ReDim Ray(1 To RwMax, 1 To Rr.Count * 2)
   
   For Each R In Rr
        If R.Offset(, 1) <> "" Then
            Ac = Ac + 2
            Ray(1, Ac - 1) = R.Value
           For n = 1 To R.Offset(, 1).Value
            Ray(n + 1, Ac - 1) = n
            Next n
        
        End If
    Next R
With Sheets("Check Sheet").Range("c7").Offset(Rw).Resize(RwMax, Ac)
  .Value = Ray
End With
Rw = Rw + RwMax + 5
Ac = 0
Next Rr
Sheets("Input Sheet").Protect Password:="ABCD1234"
End Sub

 

[amaresh achar]

Yeah.. it solved to some extent.. but still has some issues... file is here..

https://drive.google.com/file/d/1DyE6dfAX6z3IL25ajBLTDv9irvGsf-SW/view?usp=sharing

 

[MickG]

Try this:-

Sub Check_sheet()
Dim Rng As Range, Dn As Range, nRng As Range, R As Range, Rr As Range
Dim RwMax As Long, Rw As Long, Ac As Long, n As Long
With Sheets("Input Sheet")
    .Unprotect Password:="ABCD1234"
    Set Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
End With
Sheets("Check Sheet").Range("C7:M65").ClearContents
For Each Dn In Rng
If Not Dn.Value = "VARIANT" Then
    If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
End If
Next Dn
'Rw = 1
For Each Rr In nRng.Areas
RwMax = Application.Max(Rr.Offset(, 1).Value) + 1
ReDim Ray(1 To RwMax, 1 To Rr.Count * 2)
   
   For Each R In Rr
        If R.Offset(, 1) <> "" Then
            Ac = Ac + 2
            Ray(1, Ac - 1) = R.Value
           For n = 1 To R.Offset(, 1).Value
            Ray(n + 1, Ac - 1) = n
            Next n
        
        End If
    Next R
With Sheets("Check Sheet").Range("c7").Offset(Rw).Resize(RwMax, Ac)
  .Value = Ray
End With
Rw = 38
Ac = 0
Next Rr
Sheets("Input Sheet").Protect Password:="ABCD1234"
End Sub

 

[amaresh achar]

Thanks a lot Mick.. Now it works exactly as I expected...!!

 

[MickG]

You're welcome