自动从总表提取数据到新表，并且当总表新增或更新数据时，数据同步到新表

JY0818@

求助好心人，先谢过了！


需求：自动从总表提取数据到新表并根据总表同步更新数据

（1）当F列的“部门”为“甲”时，则将“甲”所在行的数据同步填入到sheet表“部门甲”；
（2）当F列的“部门”为“乙”时，则将“乙”所在行的数据同步填入到sheet表“部门乙”；
（3）当F列的“部门”为其他名称时，也相应地生成新表。
（4）以及，当部门名称修改或删除时，对应表也会修改删除。如：部门甲改成乙时，部门甲与部门乙sheet表的数据会对应修改删除更新

3190496160

Sub 更新分表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
For Each sh In Sheets
    dc(sh.Name) = ""
Next sh
With Sheets("工商银行")
    r = .Cells(Rows.Count, 6).End(xlUp).Row
    If r < 13 Then MsgBox "数据源为空！": End
    ar = .Range("e11:p" & r)
End With
For i = 3 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        d(Trim(ar(i, 2))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 3 To UBound(ar)
        If Trim(ar(i, 2)) = k Then
            n = n + 1
            br(n, 1) = n
            For j = 2 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
    If dc.exists("部门" & k) Then
        With Sheets("部门" & k)
            rs = .Cells(Rows.Count, 6).End(xlUp).Row
            If rs >= 14 Then .Range("e14:q" & rs) = Empty
            .[e14].Resize(n, UBound(br, 2)) = br
        End With
    End If
Next k
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

仅供参考
自动提取总表数据到另一张表.rar (85.25 KB, 下载次数: 17)

2023-5-24 09:56 上传

点击文件名下载附件

JY0818@

3190496160 发表于 2023-5-24 09:55
Sub 更新分表()
Application.ScreenUpdating = False
Dim ar As Variant

辛苦了大神！感激不尽！
但是还有一个小问题能不能再麻烦你一下

1、当修改部门名称时，分表自动更新
2、当新增部门名称时，自动新增分表

辛苦你了！

JY0818@

JY0818@ 发表于 2023-5-24 10:58
辛苦了大神！感激不尽！
但是还有一个小问题能不能再麻烦你一下

我有看到你在另外一个帖子回复的代码那个可以自动更新

传送门：https://club.excelhome.net/threa ... tml?_dsign=3106386d