Vba 在多列中查找重复出现的情况

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

我尝试编写的VBA将在excel中创建一个新的工作表，它将包括a列中按字母顺序排序的名称（每个名称只有一个实例），然后是B列中的一级（如果存在），以及C列中的二级（如果存在）

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

---

谢谢你的帮助

这里有一种方法

要求：

它要求你有

在Visual Basic编辑器中通过工具>引用添加对的引用

概述过程： 1）将姓名和等级读入数组。

函数

SelectRange

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

2）循环数组并创建一个带有等级的有序姓名列表。

函数

GetnameOrderedListWithGradeList

：将第1列（姓名）添加到有序列表中，该列表的键为每个人的姓名。有序列表的值是该人员在数组中找到的每个等级的串联（根据您的规范，最大值为2）。输出是一个按字母顺序排列的不同名称列表，其等级串接在一起

3）对等级的顺序进行排序，使其升序

函数

GetGradeOrderedArray

拆分连接的等级字符串，即生成等级数组，查看两个值中哪个值较高，并确保输出数组首先具有最低的数字

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

函数

WriteOutOrderedResults

确保将整个内容写入新的工作表

注意事项： 1）Sub

Main

是流程概述的地方

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

3）目前未添加错误处理

输入/输出： 输入：所选范围

输出：

代码（进入标准模块）：

选项显式
“**********要求：
'***********
'********1）.Net框架
'**********2）对Microsoft脚本运行时的引用。工具>引用>脚本.运行时
公用分干管（）
将wb设置为工作簿
设置wb=ThisWorkbook
暗淡的光线（）
'gradesArray=wb.工作表（“表3”）.范围（“A1:F10”）.值
gradesArray=SelectRange'如果要切换到硬编码范围以获得分数，请将此行注释掉并取消上面的行注释
Dim nameOrderedList作为对象
Set-nameOrderedList=GetnameOrderedListWithGradeList（gradesArray）
Dim nameGradeOrderedArray作为变量
nameGradeOrderedArray=GetGradeOrderedArray（nameOrderedList）
WriteOutOrderedResults wb.Worksheets.Add，nameGradeOrderedArray
端接头
公共函数GetnameOrderedListWithGradeList（ByVal gradesArray作为变量）作为对象
Dim nameOrderedList作为对象
Set-nameOrderedList=CreateObject（“System.Collections.SortedList”）需要.Net framework
将当前名称变长
将等级设置为字符串
昏暗的柜台一样长
将名称设置为字符串
对于currentName=LBound（gradesArray，1）到UBound（gradesArray，1），循环名称列
name=gradesArray（当前名称，1）
如果名称为vbNullString，则
暗电流等级与长电流等级相同
对于currentGrade=LBound（gradesArray，2）+1到UBound（gradesArray，2）
grade=GRADESARY（当前名称，当前等级）
如果等级为vbNullString，则找到“等级”
如果不是（nameOrderedList.contains（name）），则
nameOrderedList。添加名称，以前未见过的年级名称
其他的
nameOrderedList（名称）=联接（数组）（nameOrderedList（名称），等级），“；”）将等级添加到现有列表
如果结束
退出
如果结束
下一级
如果结束
下一个当前名称
设置GetnameOrderedListWithGradeList=nameOrderedList
端函数
作为变量的公共函数GetGradeOrderedArray（ByVal nameOrderedList作为对象）
暗淡的项目一样长
Dim orderedArray（）
Dim distinctNameCount尽可能长
distinctNameCount=nameOrderedList.Count
ReDim orderedArray（0到distinctNameCount，0到2）
Dim tempArr（）作为字符串
对于item=0，distinctNameCount-1'循环已排序的列表并提取等级
tempArr=Split（nameOrderedList.GetByIndex（项），“；”）将等级拆分为一个数组，然后分配给输出数组
orderedArray（项目，0）=nameOrderedList.GetKey（项目）
如果UBound（tempArr）=1，则
订单阵列（第1项）=IIf（节拍（0）>节拍（1）、节拍（1）、节拍（0））
订单阵列（第2项）=IIf（节拍（0）<节拍（1）、节拍（1）、节拍（0））
其他的
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