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

沈默00

顶一个，好用

125675117

不错，先留痕

今日123

Sub 拆分刷新()

Dim Conn1, Rst1, Cat1 As Object 'ado连接、ado记录集'ADO赋值
Dim strconn, strSQL1 As String
Dim k, i, t, Tbl, Dic As Object
Application.ScreenUpdating = False
Set Conn1 = CreateObject("ADODB.Connection")
Set Rst1 = CreateObject("ADODB.Recordset")
Set Cat1 = CreateObject("ADOX.Catalog")
Set Dic = CreateObject("Scripting.Dictionary")
Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
    Case Is <= 11
        strconn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & ThisWorkbook.FullName
    Case Is >= 12
        strconn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=1';" 'HDR=NO没有抬头,HDR=YES有抬头,IMEX=0写入，IMEX=1读取，IMEX=2可读可写
End Select

Application.DisplayAlerts = False
For Each sh In Worksheets '历遍sheet，配合使用字典，清空部门明细表，添加新部门，删除无用部门
    If sh.Name <> "模板" And sh.Name <> "工商银行" Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
With Sheets("工商银行")
    R = .[f65535].End(3).Row
    For i = 13 To R
        If .Cells(i, 6) <> "" Then
            Dic("部门" & .Cells(i, 6).Value) = 0
        End If
    Next i
    For Each k In Dic.keys '历遍字典，添加新部门
        If Dic(k) = 0 Then '当值0，说明是新部门，需要添加
            Sheets("模板").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k
            Dic(k) = 1
        End If
    Next k
    Conn1.Open strconn '打开数据库连接
    Cat1.Activeconnection = Conn1
    For Each Tbl In Cat1.tables
        If Tbl.Type = "TABLE" Then
            t = Replace(Tbl.Name, "'", "")
            If t = "工商银行" & "$" Then '找到汇总表
                For Each d In Dic.keys '历遍字典，
                    strSQL1 = "select * from [工商银行$F11:P10000] where 部门='" & Replace(CStr(d), "部门", "") & " '"
                    Sheets(CStr(d)).Cells(15, 6).CopyFromRecordset Conn1.Execute(strSQL1)
                Next d
                '断开ADO连接
                If Rst1.State = 1 Then '.State属性，检查记录集是否打开
                    Rst1.Close  '关闭数据库连接
                End If
            End If
        End If
    Next Tbl
    .Activate
End With
Application.ScreenUpdating = True
End Sub

xiaoqiang17

wps宏试做，你看行不行。

mmwwdd

今日123 发表于 2023-5-26 22:46
Sub 拆分刷新()

Dim Conn1, Rst1, Cat1 As Object 'ado连接、ado记录集'ADO赋值

你确定这个程序是为楼主写的？

今日123

mmwwdd 发表于 2023-5-27 03:59
你确定这个程序是为楼主写的？

是3楼的复制过来简化下

huiyuxuan

markyixia xuexi