vba读取每位员工的最高学历

ck03w11

A列是员工姓名，B列是员工学历，学历：研究生，本科，专科，提取员工最高学历，并将此员工最高学历所在行信息放到新表中。该怎样写！谢谢

ck03w11

自己顶一下，请哪位老师帮我下，谢谢！！！等……

林木水

ck03w11 发表于 2023-12-20 09:46
自己顶一下，请哪位老师帮我下，谢谢！！！等……

1. Sub 林demo()
   
2. Dim d As New Dictionary, h As Long, j As Long, arr, brr, crr(), k As Long
   
3. brr = Array("研究生", "本科", "专科")
   
4. With Sheet1
   
5.     h = .UsedRange.Rows.Count
   
6.     arr = .Range("a2:d" & h)
   
7.     For i = 1 To UBound(arr)
   
8.         If d.exists(arr(i, 1)) Then
   
9.                 If d(arr(i, 1)) = "研究生" Then
   
10.                 ElseIf d(arr(i, 1)) = "本科" Then
    
11.                     If arr(i, 3) = "研究生" Then d(arr(i, 1)) = "研究生"
    
12.                 ElseIf d(arr(i, 1)) = "专科" Then
    
13.                     If arr(i, 3) = "研究生" Then d(arr(i, 1)) = "研究生"
    
14.                     If arr(i, 3) = "本科" Then d(arr(i, 1)) = "本科"
    
15.                 End If
    
16.         Else
    
17.             d(arr(i, 1)) = arr(i, 3)
    
18.         End If
    
19.     Next
    
20.     For i = 1 To d.Count
    
21.         ReDim Preserve crr(1 To 4, 1 To i)
    
22.         crr(1, i) = d.keys(i - 1)
    
23.         For j = 1 To UBound(arr)
    
24.             If arr(j, 1) & arr(j, 3) = d.keys(i - 1) & d.items(i - 1) Then
    
25.                     crr(2, i) = arr(j, 2)
    
26.                     crr(4, i) = arr(j, 4)
    
27.                 Exit For
    
28.             End If
    
29.         Next j
    
30.         crr(3, i) = d.items(i - 1)
    
31.     Next
    
32. End With
    
33. Sheet2.Range("a2:d65535").ClearContents
    
34. Sheet2.Range("a2").Resize(d.Count, 4) = Application.Transpose(crr)
    
35. End Sub
    

复制代码

大致逻辑是用字典去重

ck03w11

林木水 发表于 2023-12-22 14:20
大致逻辑是用字典去重

谢谢！已解决了