通过VBA代码按条件取得信息

lwd5991

请大神帮助写段代码实现功能，多谢！






VBA合并文本&合并计算.7z (10.54 KB, 下载次数: 19)

2023-2-13 10:14 上传

点击文件名下载附件

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1630184&fromguid=hot&extra=&mobile&_dsign=9113f93b

ykcbf1100

用字典吧。

清风竹-

请看附件。

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "数据源为空！": End
    ar = .Range("a1:d" & r)
    Dim br()
    y = 3: k = 1
    ReDim br(1 To UBound(ar), 1 To 100)
    br(1, 1) = "老师"
    br(1, 2) = "负责班级"
    br(1, 3) = "负责班数"
   
    For i = 4 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            t = d(Trim(ar(i, 1)))
            If t = "" Then
                k = k + 1
                d(Trim(ar(i, 1))) = k
                t = k
                br(k, 1) = ar(i, 1)
            End If
            lh = d(Trim(ar(i, 3)))
            If lh = "" Then
                y = y + 1
                d(Trim(ar(i, 3))) = y
                lh = y
                br(1, y) = ar(i, 3)
            End If
            If br(t, 2) = "" Then
                br(t, 2) = ar(i, 2)
            Else
                br(t, 2) = br(t, 2) & "|" & ar(i, 2)
            End If
            br(t, lh) = br(t, lh) + ar(i, 4)
        End If
    Next i
    For i = 2 To k
        dc.RemoveAll: m = 0: zd = ""
        If InStr(br(i, 2), "|") = 0 Then
            br(i, 3) = 1
        Else
            rr = Split(br(i, 2), "|")
            For s = 0 To UBound(rr)
                If Not dc.exists(rr(s)) Then
                    m = m + 1
                    If zd = "" Then
                        zd = rr(s)
                    Else
                        zd = zd & "/" & rr(s)
                    End If
                    dc(rr(s)) = ""
                End If
            Next s
            br(i, 2) = zd
            br(i, 3) = m
        End If
    Next i
    .Range("g:z") = Empty
    .[g3].Resize(k, y) = br
End With
Application.ScreenUpdating = True
End Sub

grf1973

练习字典的较好例子。

3190496160

VBA合并文本&合并计算.rar (18.26 KB, 下载次数: 12)

2023-2-13 11:15 上传

点击文件名下载附件

grf1973

为什么在这个文件里这么简单的sql都会报错？谁来帮我解惑？

myassz

3190496160 发表于 2023-2-13 11:16

比较实用，留个记号。

lwd5991

统一回复：非常感谢各位老师的不吝赐教
@2楼：链接贴已在学习，案例文件看起来有点复杂，基本搞懂了逻辑和语法，虽然感觉和我的需求有一些差距，不过吸收了不少有用的知识，感谢感谢，回帖之快，尤为感动，必须点赞！
@3楼，@4楼，@5楼，@6楼，@7楼：初步感觉各位给的方案可以解决我的问题了，尚需进一步逐行研究一下，争取完整搞懂其内在运行思路，不辜负各位的幸苦帮忙。再次感谢！！！