VBA to assign reviewers

[krkr2784]

Hi All,

I'm looking for a way to assign reviewers to submitted papers using a few criteria:

1. submitted papers and reviewers match on a keyword related to the research field
2. each reviewer is assigned no more than 4 total reviews
3. each submitted paper is assigned 3 different reviewers that match on the keyword

I've tried to do this with INDEX & AGGREGATE functions, but I can't seem to avoid a circular reference error when trying to ensure criteria 2, above. Would love some help and guidance on this!! Thank you.

 

[Marc L]

Hi,​

​

according to your attachment try this demonstration (v3) :​

Sub Demo1()
            Const D = "¤"
            Dim V, VR(), L&, C&, R&, U&, W(1), F&
    With Sheet4.[A1].CurrentRegion.Columns(1)
            Range(.Cells(3), .Cells(.Cells.Count)).Sort .Cells(3), xlAscending, Header:=xlNo
           .AdvancedFilter xlFilterCopy, , .Range("K1"), True
        With .Range("K1").CurrentRegion
            If .Count < 3 Then .Clear: Beep: Exit Sub
            V = Range(.Cells(3), .Cells(.Count)).Value2
           .Clear
        End With
            ReDim VR(1 To UBound(V), 1)
        For L = 1 To UBound(V)
            With .Range(.Find(V(L, 1)), .Find(V(L, 1), , , , , xlPrevious)).Columns
                VR(L, 0) = Filter(Application.Transpose(.Item(2)), "", True)
                VR(L, 1) = Filter(Application.Transpose(.Item(4)), "", True)
            End With
        Next
    End With
    With Sheet3.[A1].CurrentRegion.Rows
            C = .Columns.Count - 2:  If C < 1 Then Beep: Exit Sub
            Application.ScreenUpdating = False
           .Item("3:" & .Count).Columns(3).Resize(, C).Clear
            V = Application.Match(.Columns(1), V, 0)
        For R = 3 To .Count
            If IsNumeric(V(R, 1)) Then
                   U = UBound(VR(V(R, 1), 0))
                If U > -1 Then
                    If U < C Then
                       .Cells(R, 3).Resize(, U + 1).Value2 = VR(V(R, 1), 0)
                        For L = 0 To U:  VR(V(R, 1), 1)(L) = VR(V(R, 1), 1)(L) - 1:  Next
                    Else
                       .Cells(R, 3).Resize(, C).Value2 = VR(V(R, 1), 0)
                        For L = 0 To C - 1:  VR(V(R, 1), 1)(L) = VR(V(R, 1), 1)(L) - 1:  Next
                        W(0) = VR(V(R, 1), 0):  W(1) = VR(V(R, 1), 1)
                        For L = 0 To U - C:  VR(V(R, 1), 0)(L) = W(0)(C + L):  VR(V(R, 1), 1)(L) = W(1)(C + L):  Next
                        For F = 0 To C - 1:  VR(V(R, 1), 0)(F + L) = W(0)(F):  VR(V(R, 1), 1)(F + L) = W(1)(F):  Next
                    End If
                        F = 0
                    For L = 0 To U
                        If VR(V(R, 1), 1)(L) < 1 Then F = 1: VR(V(R, 1), 0)(L) = D: VR(V(R, 1), 1)(L) = D
                    Next
                        If F Then For L = 0 To 1: VR(V(R, 1), L) = Filter(VR(V(R, 1), L), D, False): Next
                End If
            End If
        Next
    End With
            Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​

 

[krkr2784]

This is PERFECT!! Thank you so much! I'm just starting out with VBA and this will help me learn more.

 

[Marc L]

I just tweaked the procedure directly in post #2, pick up the last version …​

​

 

[Marc L]

New optimization in post #2 with more controls & a better timeline …​

​