求助大神帮助写个反向查找统计 的VBA或公式

2900357148

用字典的方法记录项目对应的人员

Public Sub 反向查找()
    Dim ArrInfo, ArrProject, ArrTemp
    Dim i%, j%
    Dim dic As Object
    Excel.Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    ArrInfo = Range("B2").CurrentRegion
    Range("M3:Z100").ClearContents
    For i = 3 To UBound(ArrInfo, 1)
        For j = 4 To UBound(ArrInfo, 2)
            If ArrInfo(i, 2) <> "停止" Then
                If Cells(i, j).Value <> "" Then
                    If Not dic(Cells(i, j).Value) Like "*" & ArrInfo(i, 1) & "*" Then
                        dic(Cells(i, j).Value) = dic(Cells(i, j).Value) & "," & ArrInfo(i, 1)
                    End If
                End If
            End If
        Next j
    Next i
    ArrProject = dic.keys
    For i = 0 To UBound(ArrProject)
        ArrTemp = Split(dic(ArrProject(i)), ",")
        Cells(i + 3, 13).Resize(, UBound(ArrTemp) + 1) = ArrTemp
    Next i
    Range("M3").Resize(UBound(ArrProject) + 1) = Excel.Application.Transpose(ArrProject)
    Excel.Application.ScreenUpdating = True
End Sub

笨鸟飞不高

现况整理.zip (15.36 KB, 下载次数: 21)

2022-12-14 12:22 上传

点击文件名下载附件

于箱长

笨鸟飞不高 发表于 2022-12-14 12:22

老师写得好精练，送花送花

gwjkkkkk

Sub TEST()
    Dim arr, vData, i&, j&, k, iPosCol&, strTxt$, iColSize&
    arr = [B2].CurrentRegion
    vData = Range([M2], [M2].End(xlDown))
    iColSize = 1
    For i = 2 To UBound(vData)
        iPosCol = 1: strTxt = vData(i, 1)
        For j = 2 To UBound(arr)
            For k = 3 To UBound(arr, 2)
               If arr(j, k) = strTxt And arr(j, 2) <> "停止" Then
                  iPosCol = iPosCol + 1
                  If iPosCol > UBound(vData, 2) Then
                        ReDim Preserve vData(1 To UBound(vData), 1 To iPosCol)
                        vData(i, iPosCol) = arr(j, 1)
                        iColSize = iColSize + 1
                        vData(1, iColSize) = "姓名" & iColSize - 1
                     Else
                        vData(i, iPosCol) = arr(j, 1)
                  End If
               End If
            Next k
        Next j
    Next i
    [M2].CurrentRegion.Offset(, 1) = Clear
    [M2].Resize(UBound(vData), UBound(vData, 2)) = vData
End Sub

gwjkkkkk

参与 一下。。。

飛

也来练个手——

1. 
   
2. <div>Sub 整理数据()
   
3. Dim rngDB As Range, arr, arrRT()
   
4. Dim dic As Object, i&, j&, k, v
   
5. 
   
6. Set dic = CreateObject("SCRIPTING.DICTIONARY") '创建字典对象
   
7. '给出对话框提示选择源数据，包含标题行
   
8. Set rngDB = Application.InputBox("请选择源数据所在单元格区域：", Default:=[B2].CurrentRegion.Address, Type:=8)
   
9. 
   
10. If Not rngDB Is Nothing Then
    
11.   arr = rngDB '将源数据存入数组
    
12.   For i = 2 To UBound(arr, 1) '行循环
    
13.     For j = 3 To UBound(arr, 2) '列循环
    
14.       If Len(arr(i, j)) > 0 And arr(i, 2) <> "停止" Then
    
15.         '将姓名与项目匹配后存入字典dic
    
16.         If dic.exists(arr(i, j)) Then
    
17.           dic.Item(arr(i, j)) = dic.Item(arr(i, j)) & "," & arr(i, 1)
    
18.         Else
    
19.           dic.Add arr(i, j), arr(i, 1)
    
20.         End If
    
21.       End If
    
22.     Next j
    
23.   Next i
    
24. End If
    
25. 
    
26. ReDim arrRT(dic.Count + 1, UBound(arr)) '定义结果存储数组
    
27. arrRT(0, 0) = "项目"
    
28. k = dic.keys '从字典中获取项目名称数组
    
29. 
    
30. For i = 0 To UBound(k)
    
31.   arrRT(i + 1, 0) = k(i) '存储项目名称
    
32.   v = Split(dic.Item(k(i)), ",") '获取项目名称对应的姓名数组
    
33.   For j = 0 To UBound(v)
    
34.     arrRT(0, j + 1) = "姓名" & j + 1 '存入列标题
    
35.     arrRT(i + 1, j + 1) = v(j) '存入姓名
    
36.   Next j
    
37. Next i
    
38. 
    
39. '提示选择单元格并存入结果
    
40. With Application.InputBox("请选择存储结果的单元格：", Default:=[T2].Address, Type:=8)
    
41.   Application.ScreenUpdating = False '关闭屏幕刷新
    
42.   .CurrentRegion.ClearContents '清空当前单元格所在区域已在的内容
    
43.   .Resize(dic.Count + 1, UBound(arr)) = arrRT '写入结果数组
    
44.   .CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes '按项目名称进行排序
    
45.   Application.ScreenUpdating = True '打开屏幕刷新
    
46. End With
    
47. 
    
48. '打扫战场
    
49. Set rngDB = Nothing
    
50. End Sub</div>

复制代码