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]

Re: Need help to generate serial numbers as described in the image

Can you please suggest modification to make this code work on locked input cells..??

 

[MickG]

Re: Need help to generate serial numbers as described in the image

Please sent an example of your current sheet data.

 

[amaresh achar]

Re: Need help to generate serial numbers as described in the image

Hi, pls check this attachment.. I have explained in the file...

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

 

[MickG]

Re: Need help to generate serial numbers as described in the image

Unfortunately because your file consists of Images of your actual sheets I can not run code on it. Please send a copy of the actual file with the current code attached.

 

[amaresh achar]

Is there any other options to attach excel file than Google drive method...!? Because Gmail servers are blocked in my office..

 

[MickG]

Try this for data in "Input Sheet" and results in "Output Sheet".

[COLOR="Navy"]Sub[/COLOR] MG29Aug59
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] RwMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Input Sheet")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not Dn.Value = "Variant" [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Rw = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] nRng.Areas
RwMax = Application.Max(Rr.Offset(, 1).Value) + 1
ReDim Ray(1 To RwMax, 1 To Rr.Count)
   
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rr
        [COLOR="Navy"]If[/COLOR] R.Offset(, 1) <> "" [COLOR="Navy"]Then[/COLOR]
            Ac = Ac + 1
            Ray(1, Ac) = R.Value
           [COLOR="Navy"]For[/COLOR] n = 1 To R.Offset(, 1).Value
            Ray(n + 1, Ac) = n
            [COLOR="Navy"]Next[/COLOR] n
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]With[/COLOR] Sheets("Output Sheet").Range("c7").Offset(Rw).Resize(RwMax, Ac)
  .Value = Ray
[COLOR="Navy"]End[/COLOR] With
Rw = Rw + RwMax + 5
Ac = 0
[COLOR="Navy"]Next[/COLOR] Rr
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

If your "Input Sheet" is protected . Please describe how it is protected

Regards Mick

 

[amaresh achar]

Format cells > protection>locked

review> protect sheet> password locking (with allow user to select locked and unlocked cells)

 

[MickG]

Assuming its the sheet your writing to (Output Sheet) that your protecting, change the code as below:-
Alter "Password" to suit !!

With Sheets("Output Sheet").Range("c7").Offset(Rw).Resize(RwMax, Ac)
  .Parent.Unprotect Password:="mick"
  .Value = Ray
 .Parent.Protect Password:="mick"
End With

 

[amaresh achar]

No.. it's the input sheet which is protected... Does it work for the same..!?

 

[MickG]

As the code is not altering the data on "Input Sheet" you soul not need to "unprotect" it.!!!