Lookup against double occurences, in multiple columns

Question

I am super new to VBA and what I have to create is way past my abilities. I need a code that would help me sort grading form results. Every name in this list occurs twice, in a random order. There is 0, 1 or maximum 2 grades per name. If there are two, they are always in separate rows. The file looks the following: Column A is an unsorted list of names, with exactly two occurrences of each name (in random rows). For each row, there is none or only one value (grade) in the range of B:AZ. The array looks something like below:

The VBA that I'm trying to write would create a new sheet in excel, that would consist of alphabetically sorted names in column A (only one instance of each name), then first grade (if exists) in column B, and second grade (if exists) in column C.

Unfortunately, because of data privacy issues I cannot share the original file.

Thanks for all your help!

Answer 1

Here is one way of doing it.

Requirements:

1. It requires you to have .Net framework
2. That you add a reference to Microsoft Scripting Runtime via Tool > References in the Visual Basic Editor.

Outline process:

1) Read Names and Grades into an array.

Function SelectRange will prompt user to select an input range of the names and grades (you can switch this in the code to a defined range) which it then assigns to an array.

2) Loop array and create an ordered list of the names with their grades.

Function GetnameOrderedListWithGradeList: Column 1 (names) are added to an ordered list, which has has as its keys the name of each person. The values for the ordered list are a concatenation of each grade found in the array for that person (max 2 according to your specification). The output is a list of alphabetically ordered distinct names with a concatenated string of their grades.

3) Sort order of grades so are ascending

Function GetGradeOrderedArray Split the concatenated grades string i.e. it generates an array of the grades, sees which of the two values is higher and ensures the output array has the lowest number first.

4) Write the results out to a newly added sheet.

Function WriteOutOrderedResults ensures the whole thing is written out to a new sheet.

Notes:

1) Sub Main is where the flow is outlined for the process

2) If I have time I will try to add some more commentary

3) No error handling added at present.

Input/Output:

Input: Selected range

Output:

Code (To go in a standard module):

Option Explicit

'***********Requirements:
'***********
'***********1) .Net framework
'***********2) Reference to Microsoft scripting runtime. Tools > References > Scripting.Runtime

Public Sub main()

    Dim wb As Workbook
    Set wb = ThisWorkbook

    Dim gradesArray()
    
    'gradesArray = wb.Worksheets("Sheet3").Range("A1:F10").Value
    gradesArray = SelectRange 'comment this line out and uncomment line above if you want to switch to hard coded range to get grades

    Dim nameOrderedList As Object
    Set nameOrderedList = GetnameOrderedListWithGradeList(gradesArray)
     
    Dim nameGradeOrderedArray As Variant
    nameGradeOrderedArray = GetGradeOrderedArray(nameOrderedList)
    
    WriteOutOrderedResults wb.Worksheets.Add, nameGradeOrderedArray
    
End Sub
Public Function GetnameOrderedListWithGradeList(ByVal gradesArray As Variant) As Object

    Dim nameOrderedList As Object
    Set nameOrderedList = CreateObject("System.Collections.SortedList") 'requires .Net framework
    
    Dim currentName As Long
    Dim grade As String
    Dim counter As Long
    Dim name As String
       
    For currentName = LBound(gradesArray, 1) To UBound(gradesArray, 1) 'loop the names column
        
        name = gradesArray(currentName, 1)
        
        If name <> vbNullString Then
            
            Dim currentGrade As Long
            
            For currentGrade = LBound(gradesArray, 2) + 1 To UBound(gradesArray, 2)
             
                grade = gradesArray(currentName, currentGrade)
              
                If grade <> vbNullString Then    'grade found
   
                    If Not (nameOrderedList.contains(name)) Then
                        
                       nameOrderedList.Add name, grade 'Name not seen before
                       
                    Else
                       
                       nameOrderedList(name) = Join(Array(nameOrderedList(name), grade), ";") 'Add grade to existing list
                    
                    End If
                    
                    Exit For
                End If
       
            Next currentGrade
    
        End If
    
    Next currentName

    Set GetnameOrderedListWithGradeList = nameOrderedList
     
End Function

Public Function GetGradeOrderedArray(ByVal nameOrderedList As Object) As Variant

    Dim item As Long
    Dim orderedArray()
    Dim distinctNameCount As Long
    distinctNameCount = nameOrderedList.Count
    
    ReDim orderedArray(0 To distinctNameCount, 0 To 2)
    Dim tempArr() As String
  
    For item = 0 To distinctNameCount - 1       'loop the ordered list and pull of the grades
       
        tempArr = Split(nameOrderedList.GetByIndex(item), ";") 'split the grades out into an array and then assign to output array
        
        orderedArray(item, 0) = nameOrderedList.GetKey(item)
       
        If UBound(tempArr) = 1 Then
        
            orderedArray(item, 1) = IIf(tempArr(0) > tempArr(1), tempArr(1), tempArr(0))
       
            orderedArray(item, 2) = IIf(tempArr(0) < tempArr(1), tempArr(1), tempArr(0))
       
        Else
        
            orderedArray(item, 1) = tempArr(0)
          
        End If
       
    Next item
   
    GetGradeOrderedArray = orderedArray
 
End Function

Public Function WriteOutOrderedResults(ByVal destinationSheet As Worksheet, ByVal nameGradeOrderedArray As Variant) As Variant
   
    destinationSheet.Range("A1").Resize(UBound(nameGradeOrderedArray, 1), UBound(nameGradeOrderedArray, 2) + 1) = nameGradeOrderedArray

End Function