求问下如何根据特定条件提取表格数据

cjc209

更正加上姓名去重
Sub 汇总()
    Dim brr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("a2:c" & Range("A" & Rows.Count).End(xlUp).Row)
    ReDim brr(1 To 1, 1 To 3)
    For r = 1 To UBound(arr, 1)
        关键字 = arr(r, 2)
        If Not d.Exists(关键字) Then
            brr(1, 1) = Split(arr(r, 1), " ")(0)
            If Len(arr(r, 3)) > 0 Then brr(1, 3) = arr(r, 3)
            d(关键字) = brr
        Else
            brr = d(关键字)
            brr(1, 2) = Split(arr(r, 1), " ")(0)
            If Len(arr(r, 3)) > 0 And InStr(brr(1, 3), arr(r, 3)) = 0 Then brr(1, 3) = brr(1, 3) & "、" & arr(r, 3)
            d(关键字) = brr
        End If
    Next r
    For Each Key In d.keys
        [e12].Offset(m).Resize(1, 3) = Key & "日期"
        m = m + 1
    Next
    For Each Key In d.items
        [f12].Offset(k).Resize(1, 3) = Key
        k = k + 1
    Next
End Sub

cjc209

再更正
Sub 汇总()
    Dim brr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("a2:c" & Range("A" & Rows.Count).End(xlUp).Row)
    ReDim brr(1 To 1, 1 To 3)
    For r = 1 To UBound(arr, 1)
        关键字 = arr(r, 2)
        If Not d.Exists(关键字) Then
            brr(1, 1) = Split(arr(r, 1), " ")(0)
            If Len(arr(r, 3)) > 0 Then brr(1, 3) = arr(r, 3)
            d(关键字) = brr
        Else
            brr = d(关键字)
            brr(1, 2) = Split(arr(r, 1), " ")(0)
            If Len(arr(r, 3)) > 0 And InStr("、" & brr(1, 3) & "、", "、" & arr(r, 3) & "、") = 0 Then brr(1, 3) = brr(1, 3) & "、" & arr(r, 3)
            d(关键字) = brr
        End If
    Next r
    For Each Key In d.keys
        [e12].Offset(m).Resize(1, 3) = Key & "日期"
        m = m + 1
    Next
    For Each Key In d.items
        [f12].Offset(k).Resize(1, 3) = Key
        k = k + 1
    Next
End Sub

瞬息人间

魚。。 发表于 2020-12-10 21:34
F12公式：
=MINIFS(A:A,B:B,LEFT(E12,2))

你好，前2个公式好简单啊，谢谢了，但是第三个公式打开显示#NAME？，从你附件打开也是显示这个

瞬息人间

cjc209 发表于 2020-12-10 23:44
再更正
Sub 汇总()
    Dim brr

谢谢解答，不过我公司内部系统是用WPS，用宏好像要付费，但是因为不联网，想付费都没法付费。

魚。。

瞬息人间 发表于 2020-12-11 10:12
你好，前2个公式好简单啊，谢谢了，但是第三个公式打开显示#NAME？，从你附件打开也是显示这个

H12数组公式：

=TEXTJOIN("、",,IF(MATCH(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B$2:B$9=LEFT(E12,2),C$2:C$9&"",""),"微信",),"支付宝",),"未知",),SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B$2:B$9=LEFT(E12,2),C$2:C$9&"",""),"微信",),"支付宝",),"未知",),)=ROW($1:$8),SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B$2:B$9=LEFT(E12,2),C$2:C$9&"",""),"微信",),"支付宝",),"未知",),""))


没有优化，能用，或者就是添加辅助列好写一些

瞬息人间

魚。。 发表于 2020-12-11 20:05
H12数组公式：

=TEXTJOIN("、",,IF(MATCH(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(IF(B$2:B$9=LEFT(E12,2), ...

你好，是这样的，我列的只是某个比较少数据，某些原始数据可能几百行这样，刚刚尝试公式扩大行数范围，好像又不行了（我通常把公式通常设为第二页，这样我原始数据粘贴到第一页，第二页自动生成我想要东西）

魚。。

瞬息人间 发表于 2020-12-11 21:26
你好，是这样的，我列的只是某个比较少数据，某些原始数据可能几百行这样，刚刚尝试公式扩大行数范围，好 ...

那应该是你的公式没有扩对

瞬息人间

魚。。 发表于 2020-12-11 22:10
那应该是你的公式没有扩对

大佬，这个没有时候顿号能不能没有呀，现实数据上会出现，几百条数据后，很多名字空格，但也没法一次删除这样。数据少页数还能手工一下，上千页会受不了。如下图：




还有这个参数$1:$8，是必须设为最后倒数第二行么？我这个每个表格最低1行，最高20000行。。。没法每次这样每次调整行数
还有就是

B$2:B$9、C$2:C$9貌似替换成B:B,C:C，或者设置B$2:B$2000、C$2:C$2000这样都不行的，但是因为原始数据上确实还是行数不固定的原因，只能预揽括里面。

瞬息人间

魚。。 发表于 2020-12-11 22:10
那应该是你的公式没有扩对

如果一条公式没法一次得出结果，或者有没有办法分开几个格子公式最终得出结果就好了？

Excel表哥在此

瞬息人间 发表于 2020-12-12 19:38
如果一条公式没法一次得出结果，或者有没有办法分开几个格子公式最终得出结果就好了？

这也是个不错的主意喔！