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

 

[MickG]

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

Try this for Data on sheet1, results on sheet2.
Based on your link

[COLOR=navy]Sub[/COLOR] MG28Aug39
[COLOR=navy]Dim[/COLOR] Rng1 [COLOR=navy]As[/COLOR] Range, Rng2 [COLOR=navy]As[/COLOR] Range, Ray [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Rw [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] cols [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Num [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
    [COLOR=navy]Set[/COLOR] Rng1 = .Range("D5", .Range("D5").End(xlDown))
    [COLOR=navy]Set[/COLOR] Rng2 = .Range("D14", .Range("D14").End(xlDown))
[COLOR=navy]End[/COLOR] With
Ray = Array(Rng1, Rng2)

[COLOR=navy]For[/COLOR] n = 0 To 1
    Ac = 0: c = 0
    cols = Ray(n).Offset(, 1).SpecialCells(xlConstants).Count
    ReDim nRay(1 To Application.Max(Ray(n).Offset(, 1)) + 1, 1 To cols)
   
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Ray(n)
        [COLOR=navy]If[/COLOR] Not IsEmpty(Dn.Offset(, 1)) [COLOR=navy]Then[/COLOR]
           Ac = Ac + 1
           nRay(1, Ac) = Dn.Value
           [COLOR=navy]For[/COLOR] Rw = 1 To Dn.Offset(, 1).Value
            nRay(Rw + 1, Ac) = Rw
           [COLOR=navy]Next[/COLOR] Rw
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
Num = IIf(n = 0, 0, Ray(0).Count + 5)
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("C3").Offset(Num).Resize(UBound(nRay, 1), cols)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] With

[COLOR=navy]Next[/COLOR] n
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[amaresh achar]

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

Hi MickG.. Thanks a lot...!!! Its great..!! And I want a small suggestion from you w.r.t your code....i.e. How do I space the output in intermittent column like, now its continuously in C,D,E,F,G,H,I,J,K,L,M.. and if I want to keep my output in C, E, G, I, K, M by keeping column D,F,H,J,L blank... What modifications in the code need to be done..???

 

[MickG]

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

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG28Aug22
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Rng2 [COLOR="Navy"]As[/COLOR] Range, Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cols [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng1 = .Range("D5", .Range("D5").End(xlDown))
    [COLOR="Navy"]Set[/COLOR] Rng2 = .Range("D14", .Range("D14").End(xlDown))
[COLOR="Navy"]End[/COLOR] With
Ray = Array(Rng1, Rng2)

[COLOR="Navy"]For[/COLOR] n = 0 To 1
    Ac = 0: c = 0
    cols = Ray(n).Offset(, 1).SpecialCells(xlConstants).Count
    ReDim nRay(1 To Application.Max(Ray(n).Offset(, 1)) + 1, 1 To cols * 2)
   
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ray(n)
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, 1)) [COLOR="Navy"]Then[/COLOR]
           Ac = Ac + 1
           nRay(1, Ac) = Dn.Value
           [COLOR="Navy"]For[/COLOR] Rw = 1 To Dn.Offset(, 1).Value
            nRay(Rw + 1, Ac) = Rw
           [COLOR="Navy"]Next[/COLOR] Rw
           Ac = Ac + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
Num = IIf(n = 0, 0, Ray(0).Count + 5)
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("C3").Offset(Num).Resize(UBound(nRay, 1), (cols * 2) - 1)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[amaresh achar]

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

Thanks again Mick...!! Code worked perfectly...!!! Thanks a lot...!

 

[MickG]

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

You're welcome

 

[amaresh achar]

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

Hey Mick.. if I change the input value say about 36 against any item in "office supplies" section, the output table remain limited up to serial number 12.. how to expand it..??

 

[MickG]

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

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG28Aug42
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Rng2 [COLOR="Navy"]As[/COLOR] Range, Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cols [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng1 = .Range("D5", .Range("D5").End(xlDown))
    [COLOR="Navy"]Set[/COLOR] Rng2 = .Range("D14", .Range("D14").End(xlDown))
[COLOR="Navy"]End[/COLOR] With
Ray = Array(Rng1, Rng2)

[COLOR="Navy"]For[/COLOR] n = 0 To 1
    Ac = 0: c = 0
    cols = Ray(n).Offset(, 1).SpecialCells(xlConstants).Count
    ReDim nRay(1 To Application.Max(Ray(n).Offset(, 1)) + 1, 1 To cols * 2)
   
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ray(n)
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Offset(, 1)) [COLOR="Navy"]Then[/COLOR]
           Ac = Ac + 1
           nRay(1, Ac) = Dn.Value
           [COLOR="Navy"]For[/COLOR] Rw = 1 To Dn.Offset(, 1).Value
            nRay(Rw + 1, Ac) = Rw
           [COLOR="Navy"]Next[/COLOR] Rw
           Ac = Ac + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
Num = IIf(n = 0, 0, nRw + 5)
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("C3").Offset(Num).Resize(UBound(nRay, 1), (cols * 2) - 1)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
nRw = UBound(nRay, 1)
[COLOR="Navy"]Next[/COLOR] n

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[amaresh achar]

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

Hi Mick, the code runs perfectly on one workbook... and if I transfer the same code to another workbook with same cell references and sheet names.. it is giving some runtime error 13: Type mismatch in this line: " For Rw = 1 To Dn.Offset(, 1).Value "


Can you please tell me how to fix it..??

 

[amaresh achar]

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

Ok.. fixed the issue.. Reason: cell reference was improper..

Now am receiving strange output.. both office supplies and hardware items appear in upper table and hardware items again appear in lower table.. how to fix this...??