在多列中查找双重出现

Question

我是VBA的新手，我必须创造的是超越自己的能力。我需要一个代码来帮助我对分级表单结果进行排序。此列表中的每个名称都以随机顺序出现两次。每个名称有0,1或最多2个等级。如果有两个，它们总是在不同的行中。该文件如下所示：列A是未排序的名称列表，每个名称恰好出现两次（随机行）。对于每一行，在B：AZ范围内没有或只有一个值（等级）。该数组如下所示：

我尝试编写的VBA将在Excel中创建一个新工作表，其中包含A列中按字母顺序排序的名称（每个名称只有一个实例），然后是列中的第一个等级（如果存在） B和C列中的二年级（如果存在）

不幸的是，由于数据隐私问题，我无法共享原始文件。

感谢您的帮助！

Answer 1

这是一种做法。

要求：

1. 它要求您拥有.Net framework
2. 您通过工具＆gt;添加对Microsoft Scripting Runtime的引用Visual Basic编辑器中的参考。

大纲过程：

1） 将姓名和等级读入数组。

函数SelectRange将提示用户选择名称和等级的输入范围（您可以在代码中将其切换到定义的范围），然后将其分配给数组。

2） 循环数组并创建一个包含其成绩的名称的有序列表。

函数GetnameOrderedListWithGradeList：将列1（名称）添加到有序列表中，该列表的每个人的名称都是其键。有序列表的值是数组中为该人找到的每个等级的串联（根据您的规范最多2个）。输出是按字母顺序排列的不同名称列表，其中包含其成绩的串联字符串。

3） 按等级排序顺序为升序

函数GetGradeOrderedArray拆分连接的成绩字符串，即它生成一个成绩数组，查看哪两个值更高，并确保输出数组的编号最小。

4） 将结果写入新添加的工作表。

函数WriteOutOrderedResults可确保将整个内容写入新工作表。

备注：

1）子Main是流程概述流程的地方

2）如果我有时间，我会尝试添加更多评论

3）目前没有添加错误处理。

输入/输出：

输入：所选范围



<强>输出：



代码（进入标准模块）：

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