Center wise duty list creation from an existing mixed duty list

[awanak]

I want to create a center wise duty list from an existing mixed center wise duty list

Mixed center wise duty list

S.No	Name	Center
1	Gul Nisar	Lahore-1
2	Jamil Ahmad Siddiqui	Lahore-5
3	Muhammad Ashraf	Lahore-2
4	Naeem Akhtar	Lahore-4
5	Munir Ahmad Malik	Lahore-2
6	Muhammad Amjad	Lahore-2
7	Muhammad Saleem Arain	Lahore-3
8	Zubair Khan	Lahore-1
9	S.M. Ibrahim	Lahore-1
10	Muhammad Khan	Lahore-7
11	Bashir Ahmad	Lahore-6
12	Naseer Khan	Lahore-9
13	Fida Muhammad	Lahore-2
14	Alam Shah	Lahore-3
15	Asghar Ali Asghar	Lahore-6
16	Mumtaz Ali	Lahore-5
17	Iftikhar Ahmad	Lahore-1
18	Sardar Javed Akhtar	Lahore-6
19	Shoukat Ali Mirza	Islamabad-1
20	Muhammad Boota Asim	Islamabad-1
21	Muhammad Rukhtaj	Lahore-6
22	Tanveer Muhammad Khan	Islamabad-2
23	S.Imran Hassan	Islamabad-2
24	Shakeel Ahmed	Islamabad-1
25	Imran Asghar	Islamabad -1
26	Tariq Ali Lahori	Lahore-1

<tbody>
</tbody>

Center wise Duty list to be created

Name & Center

Islamabad-1

Imran Asghar

Shoukat Ali Mirza

Muhammad Boota Asim

Shakeel Ahmed

Islamabad-2

Tanveer Muhammad

S.Imran Hassan

Lahore-1

Gul Nisar

Zubair Khan

S.M. Ibrahim

Iftikhar Ahmad

Tariq Ali Lahori

Lahore-2

Muhammad Ashraf

Munir Ahmad Malik

Muhammad Amjad

Fida Muhammad

Lahore-3

Muhammad Saleem Arain

Alam Shah

Lahore-4

Naeem Akhtar

Lahore-5

Jamil Ahmad Siddiqui

Mumtaz Ali

Lahore-6

Bashir Ahmad

Asghar Ali Asghar

Sardar Javed Akhtar

Muhammad Rukhtaj

Lahore-7

Muhammad Khan

Lahore-9

Naseer Khan

<tbody>
</tbody>

<tbody>
</tbody>

 

[MickG]

To show the results on sheet2 then:-
Alter this line :-

Range("F1").Resize(c).Value = Ray

To this:-

sheets("Sheet2").Range("A1").Resize(c).Value = Ray

 

[awanak]

it gives the error "Subscript out of range"

 

[MickG]

Have you got a sheet Named "Sheet2" ????

 

[awanak]

thanks buddy, got the desired output on sheet2, however, when i enter a center name and number e.g. Skardu-1, it gives the error "Subscript out of range". This center is most probably 7th or 8th center name. need help for entering multiple center names and numbers around 150 or more centers are to be setup for exam

 

[MickG]

Try changing the line below to "3"

ReDim Ray(1 To Rng.Count *[COLOR="#FF0000"][B][SIZE=3] 3[/SIZE][/B][/COLOR], 1 To 2)

 

[awanak]

Thanks a lot. it works. another question is that, if i have the original duty list to be as under

S.No	Name	Designaiton	Place of Postings	Center
1	Gul Nisar	Assistant	CE Directorate	Lahore-1

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>

I want create center wise duty list but with the format as given below:
Lahore-1
Gul Nisar, Assistant (CE Directorate)

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG21Oct21
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, KK [COLOR="Navy"]As[/COLOR] Variant, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]

[COLOR="Navy"]Set[/COLOR] Rng = Range("E2", Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn.Offset(, -3) & ", " & Dn.Offset(, -2).Value & " (" & Dn.Offset(, -1).Value & ")"
    [COLOR="Navy"]Else[/COLOR]
        .Item(Dn.Value) = .Item(Dn.Value) & "/" & Dn.Offset(, -3) & ", " & Dn.Offset(, -2).Value & " (" & Dn.Offset(, -1).Value & ")"
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

ReDim Ray(1 To Rng.Count * 3, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    Txt = Split(K, "-")(0)
    Dic(Txt) = Dic(Txt) + 1
[COLOR="Navy"]Next[/COLOR] K
c = 1
Ray(c, 1) = "Center:=Name/Desg/Post"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] KK [COLOR="Navy"]In[/COLOR] Dic.keys
    [COLOR="Navy"]For[/COLOR] n = 1 To 50
        [COLOR="Navy"]If[/COLOR] .exists(KK & "-" & n) [COLOR="Navy"]Then[/COLOR]
            c = c + IIf(c = 1, 1, 2)
            Ray(c, 1) = KK & "-" & n
            Sp = Split(.Item(Ray(c, 1)), "/")
                [COLOR="Navy"]For[/COLOR] nn = 0 To UBound(Sp)
                    c = c + 1
                    Ray(c, 1) = Sp(nn)
                [COLOR="Navy"]Next[/COLOR] nn
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] KK
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[awanak]

Thanks Mick. there is a problem, when there are blanks in between centers assigned to different employees, it gives the error "Subscript out of range". moverover, i have more than 650 employees and almost 600 are assigned duties at different cities with different center numbers.

 

[MickG]

I've altered the code slightly to increase the array dimensions, and tried on 2000plus rows with multiple and single employees without error.
If this does not work for you, can you sent a redacted file of the data that fails, using "Box" or "DropBox"
Mod to code:-
Change line in red

For Each KK In Dic.Keys
    [COLOR="#FF0000"]For n = 1 To Rng.Count * 3
[/COLOR]        If .Exists(KK & "-" & n) Then

 

[awanak]

If some of the cells are blank in the center, the same error occurs "Subscript out of range"