Group sort candidates

[technik]

Hi

I have a list of candidates with some data which I need to sort into 4 groups using VBA. The number of candidates can change so the group tab needs to be able to "extend" itself.

The candidate data (tab 2) itself is displayed in 2 parts (Columns B to D and Columns H to J). Ideally, once grouped, I need to distinguish between these 2 sets of groups. At the moment I have just used two colours (Orange Group and Blue Group).

I have attached my DUMMY DATA sheet and on the first tab I have shown part of how the end result should look like.

Can anyone help?

Many thanks in advance.

[technik]

I have made some progress with this however not quite there yet. Was hoping someone could take a look and help please? Uploaded my file again.

[davesexcel]

From what I remember I spent many hours on the first sample and not able to spend that kind of time on this at the moment.

You should be able to copy and paste the ranges such as this will copy the contents of the candidates cell and paste it into the groups cell

    Sheets("candidates").Range("E3").Copy Sheets("groups").Range("C7")

Just a test, loop through your orange group and copy the pictures into groups sheet

Sub Button2_Click()
Dim sh As Worksheet, ws As Worksheet
Dim rng As Range, c As Range, x

Set sh = Sheets(1)
Set ws = Sheets(2)

x = 7
With sh
Set rng = .Range("D3:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
For Each c In rng.Cells
c.Offset(, 1).Copy ws.Cells(x, 3)
x = x + 2
Next c
End With



End Sub

[technik]

Hi Dave

Thanks for your post and I appreciate your time and help.

The specific difficulty in coding I am having is :

1.checking which group number the candidate(s) in the Orange group AND Blue Group belong to (by looking at the data worksheet).
2. If belong to Group 1 then (only) copy those photo(s) and associated data to the 'groups' tab in the 'Group 1' section

If I can get that working then I can just re-create that for the other groups (of all 4 groups cannot be done in one macro)

I'd really appreciate it if you could look at my updated sheet and I think you will have a better idea of what I mean. This issue is not at all as time consuming as the previous issue as I think it's just looping through to check and copy/paste and not dealing with lots of named ranges.

Really appreciate it - many thanks.

[davesexcel]

The key would be the admin numbers.

Get the admin numbers from the data sheet and put them in the groups sheet, then from there you can get the admin numbers to find the
correct picture to copy.

Sub FirstMacro()
Dim sh As Worksheet, ws As Worksheet, sh2 As Worksheet
Dim gp1 As Range, gp2 As Range, gp3 As Range, gp4 As Range
Dim rng As Range, c As Range
Dim rw, cl, x
Set sh = Sheets("Groups")
Set ws = Sheets("data")
Set sh1 = Sheets("candidates")

With sh
Set gp1 = .Cells.Find("Group 1")
Set gp2 = .Cells.Find("Group 2")
Set gp3 = .Cells.Find("Group 3")
Set gp4 = .Cells.Find("Group 4")
.Range("E7:F23,K7:L23,K28:L43,E28:F42").ClearContents
.Pictures.Delete
End With
x = 2
With ws
Set rng = .Range("E2:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
For Each c In rng.Cells
If c = "Group 1" Then
rw = gp1.Row + 1
cl = gp1.Column + 3
sh.Cells(rw + x, cl) = c.Offset(, -1)
sh.Cells(rw + x, cl + 1) = c.Offset(, 2)
x = x + 2
End If
Next c
x = 2
For Each c In rng.Cells
If c = "Group 2" Then
rw = gp2.Row + 1
cl = gp2.Column + 3
sh.Cells(rw + x, cl) = c.Offset(, -1)
sh.Cells(rw + x, cl + 1) = c.Offset(, 2)

x = x + 2
End If
Next c
x = 2
For Each c In rng.Cells
If c = "Group 3" Then
rw = gp3.Row + 1
cl = gp3.Column + 3
sh.Cells(rw + x, cl) = c.Offset(, -1)
sh.Cells(rw + x, cl + 1) = c.Offset(, 2)
x = x + 2
End If
Next c
x = 2
For Each c In rng.Cells
If c = "Group 4" Then
rw = gp4.Row + 1
cl = gp4.Column + 3
sh.Cells(rw + x, cl) = c.Offset(, -1)
sh.Cells(rw + x, cl + 1) = c.Offset(, 2)
x = x + 2
End If
Next c
End With

SecondMacro


End Sub
Sub SecondMacro()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, c As Range
    Dim fndRng As Range
    
    Set sh = Sheets(2)
    Set ws = Sheets(1)
    
    With sh
    Set rng = .Range("E:E,K:K").SpecialCells(xlCellTypeConstants, 1)
    For Each c In rng.Cells
    With ws
    Set fndRng = .Cells.Find(c, LookIn:=xlValues)
    If Not fndRng Is Nothing Then
    fndRng.Offset(, 1).Copy c.Offset(, -2)
    End If
    End With
    Next c
    End With
End Sub

[technik]

Hi Dave.

Thanks - that's a great help.

In the second macro could you please explain what

(LookIn:=xlValues)

is doing? When I try running this on my master sheet it says "no cells were found" with the line below highlighted

Set rng = .Range("E:E,K:K").SpecialCells(xlCellTypeConstants, 1)

I'm assuming this is where it is searching for the admin number?

The range on worksheet2 is the same as on my master sheet however worksheet1 (candidates tab) obviously has more/less candidates so not sure this is an issue?

Many thanks once again

[davesexcel]

You need the lookin:=xlvalues, didn't see required this morning.

Set ct = CntRng.Find(c.Offset(, -1), LookIn:=xlValues)

[technik]

Sorry Dave where would I add/amend this code?

Here is the 1st and 2nd macro at the moment

   Sub FirstMacro()
    Dim sh As Worksheet, ws As Worksheet, sh2 As Worksheet
    Dim gp1 As Range, gp2 As Range, gp3 As Range, gp4 As Range
    Dim rng As Range, c As Range
    Dim rw, cl, x
    Dim CntRng As Range
    Set sh = Sheets("groups")
    Set ws = Sheets("data")
    Set sh1 = Sheets("candidates")
    
    With sh1
        Set CntRng = .Range("C:C,H:H")
    End With
    
    With sh
        Set gp1 = .Cells.Find("Group 1")
        Set gp2 = .Cells.Find("Group 2")
        Set gp3 = .Cells.Find("Group 3")
        Set gp4 = .Cells.Find("Group 4")
        .Range("D7:F61,J7:L61,J28:L82,D28:F82").ClearContents
        .Pictures.Delete
    End With

    x = 2
    With ws
        Set rng = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 1" Then
                    rw = gp1.Row + 1
                    cl = gp1.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 2" Then
                    rw = gp2.Row + 1
                    cl = gp2.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 3" Then
                    rw = gp3.Row + 1
                    cl = gp3.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 4" Then
                    rw = gp4.Row + 1
                    cl = gp4.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
 
    End With

    SecondMacro


End Sub

Sub SecondMacro()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, c As Range
    
    Dim fndRng As Range
    
    Set sh = Sheets(2)
    Set ws = Sheets(1)
    
    With sh
        Set rng = .Range("E:E,K:K").SpecialCells(xlCellTypeConstants, 1)
        For Each c In rng.Cells
            With ws
                Set fndRng = .Cells.Find(c, LookIn:=xlValues)
                If Not fndRng Is Nothing Then
                    fndRng.Offset(, 1).Copy c.Offset(, -2)
                End If
            End With
        Next c
    End With
End Sub

[davesexcel]

In the Firstmacro, you need to have it in 4 lines.

Sub FirstMacro()
    Dim sh As Worksheet, ws As Worksheet, sh2 As Worksheet
    Dim gp1 As Range, gp2 As Range, gp3 As Range, gp4 As Range
    Dim rng As Range, c As Range
    Dim rw, cl, x
    Dim CntRng As Range
    Set sh = Sheets("groups")
    Set ws = Sheets("data")
    Set sh1 = Sheets("candidates")
    
    With sh1
        Set CntRng = .Range("C:C,H:H")
    End With
    
    With sh
        Set gp1 = .Cells.Find("Group 1")
        Set gp2 = .Cells.Find("Group 2")
        Set gp3 = .Cells.Find("Group 3")
        Set gp4 = .Cells.Find("Group 4")
        .Range("D7:F61,J7:L61,J28:L82,D28:F82").ClearContents
        .Pictures.Delete
    End With

    x = 2
    With ws
        Set rng = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1), LookIn:=xlValues)
            If Not ct Is Nothing Then
                If c = "Group 1" Then
                    rw = gp1.Row + 1
                    cl = gp1.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    'sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1), LookIn:=xlValues)
            If Not ct Is Nothing Then
                If c = "Group 2" Then
                    rw = gp2.Row + 1
                    cl = gp2.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    'sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1), LookIn:=xlValues)
            If Not ct Is Nothing Then
                If c = "Group 3" Then
                    rw = gp3.Row + 1
                    cl = gp3.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    'sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1), LookIn:=xlValues)
            If Not ct Is Nothing Then
                If c = "Group 4" Then
                    rw = gp4.Row + 1
                    cl = gp4.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    'sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
 
    End With

    SecondMacro


End Sub

Sub SecondMacro()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, c As Range
    Dim fndRng As Range
    
    Set sh = Sheets(2)
    Set ws = Sheets(1)
    
    With sh
        Set rng = .Range("E:E,K:K").SpecialCells(xlCellTypeConstants, 1)
        For Each c In rng.Cells
            With ws
                Set fndRng = .Cells.Find(c, LookIn:=xlValues)
                If Not fndRng Is Nothing Then
                    fndRng.Offset(, 1).Copy c.Offset(, -2)
                End If
            End With
        Next c
    End With
End Sub

[davesexcel]

SpecialCells(xlCellTypeConstants, 1)

This is just a short way of making just numbered cells the range, or the loop will end up going through ever cell in the columns.

Your sample uses admin numbers, actual numbers that's why I went this way, if the admin # are not actual numbers, you can change that 1 to a 23.

"No cells were found" is not the find line it is the specialcells that can't find numbers.

[technik]

Thanks Dave.

A bit confused as the admin numbers ARE numbers (that are listed using a VLOOKUP). They are there on the 1st candidates tab. Obviously on the 2nd 'groups' tab all the candidate data/info needs to populate itself via the macro.

I've attached my test sheet - can't see why I am still getting the error as everything is identical ... I think ???????????????

[davesexcel]

Refer to post #7

[davesexcel]

The Groups in the group column in Data sheet are not the same groups in code Group1 <>Group 1
You are over writing the Admin # with the name

-
2020-06-03_19-35-36.jpg

[technik]

Thanks Dave - have corrected that now.

The code does seem to run but I need to check two things:

1. If there are no candidates in a particular group, the code will just not display any data for that section?
2. If you have a look at my attached sheet, there are 41 candidates in the orange+blue group (tab1) although there are 60 candidates altogether (see data tab). Now in the 'groups' worksheet (tab2) there should only be 41 candidates as this worksheet is only meant to show the candidates in the orange+blue groups. At the moment all 60 candidates are being shown in the 'groups' worksheet and that is not the idea. Sorry if this was not clear in post#4.

[davesexcel]

Try it now,

Sub FirstMacro()
    Dim sh As Worksheet, ws As Worksheet, sh2 As Worksheet
    Dim gp1 As Range, gp2 As Range, gp3 As Range, gp4 As Range
    Dim rng As Range, c As Range
    Dim rw, cl, x
    Dim CntRng As Range
    Set sh = Sheets("groups")
    Set ws = Sheets("data")
    Set sh1 = Sheets("candidates")
    
    With sh1
        Set CntRng = .Range("C:C,H:H")
    End With
    
    With sh
        Set gp1 = .Cells.Find("Group 1")
        Set gp2 = .Cells.Find("Group 2")
        Set gp3 = .Cells.Find("Group 3")
        Set gp4 = .Cells.Find("Group 4")
        .Range("D7:F61,J7:L61,J28:L82,D28:F82").ClearContents
        .Pictures.Delete
    End With

    x = 2
    With ws
        Set rng = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 1" Then
                    rw = gp1.Row + 1
                    cl = gp1.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 2" Then
                    rw = gp2.Row + 1
                    cl = gp2.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c

        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 3" Then
                    rw = gp3.Row + 1
                    cl = gp3.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
        x = 2
        For Each c In rng.Cells
            Set ct = CntRng.Find(c.Offset(, -1))
            If Not ct Is Nothing Then
                If c = "Group 4" Then
                    rw = gp4.Row + 1
                    cl = gp4.Column + 3
                    sh.Cells(rw + x, cl) = c.Offset(, -1) 'admin number
                    sh.Cells(rw + x, cl - 1) = c.Offset(, -2) 'name
                    sh.Cells(rw + x, cl + 1) = c.Offset(, 2) 'score
                    x = x + 2
                End If
            End If
        Next c
 
    End With

    SecondMacro


End Sub

Sub SecondMacro()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, c As Range
    Dim fndRng As Range
    
    Set sh = Sheets(2)
    Set ws = Sheets(1)
    
    With sh
        Set rng = .Range("E:E,K:K").SpecialCells(xlCellTypeConstants, 1)
        For Each c In rng.Cells
            With ws
                Set fndRng = .Cells.Find(c, LookIn:=xlValues)
                If Not fndRng Is Nothing Then
                    fndRng.Offset(, 1).Copy c.Offset(, -2)
                End If
            End With
        Next c
    End With
End Sub

[technik]

Thanks Dave.

Everything looks fine but bizarrely getting an error on the second macro. Can't work out where the issue is as everything looks ok.

Very strange as can't see what is missing and what it is not liking. One thing I notice was that upon running the code the 1st time, (I am sure) the group were correctly ordered. When I closed the sheet down and the ran the code again, that's when I get the error. So I think something gets deleted between the runs and that's why I get the error??

[technik]

Forgot to mention that the "xlCellTypeConstants" is showing as =2 when I hover over it. Don't think this is correct?

[technik]

Thanks Dave - will try it.

And thank you for your patience with me!

[technik]

Hi Dave

The code generally runs ok however I have come across one issue. When copying admin numbers across from my master sheet, I keep getting the same error as above and the picture(s) also does not load. If I remove any trailing zeros (e.g change 000812 to 812) from all admin numbers, I no longer get the error. Problem is I need the exact admin number as it is (as I am using those exact admin numbers to loads the pics on the 1st candidates ws).

Why would trailing zeros cause an issue?

[davesexcel]

How are the leading zeros being entered on the worksheet?

[technik]

The numbers themselves are just being copied from another sheet .. right-click ... paste as Values onto my master sheet.

I have tried 'formatting' the numbers as 'General', 'Number', 'Text' to no avail. Maybe the issue is in the actual pasting of the numbers I am not sure.

I have both working and non-working versions so you can see the error in action.

Thanks again

[technik]

Thanks Dave - and thanks again for all your help.