按要求拆分汇总工作表生成新的工作表

3190496160

我的主题里面的一个拆分工具完全可以解决的，选择主关键字，次关键字拆分就行

ZHLK

Sub 宏1()
Dim sht As Worksheet
Application.DisplayAlerts = False
For Each sht In Worksheets
    If sht.Name <> "计算" Then
        sht.Delete
    End If
Next
Application.DisplayAlerts = True
For i = 2023 To 2024
    For j = 1 To 12
        Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
        sht.Name = i & Format(j, "00")
        sht.Select
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
            "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";DefaultDir=C:\Users\Administrator\" _
            ), Array( _
            "Desktop\按要求拆分汇总工作表生成新的工作表;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;")), _
            Destination:=Range("$A$1")).QueryTable
            .CommandText = "SELECT 个人编号,性别,档案出生日期,个人身份,退休类别,法定退休年龄,应退年度,应退月份 FROM [计算$] where 应退年度=" & i & " and 应退月份=" & j
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .PreserveColumnInfo = True
            .ListObject.DisplayName = "表_" & i & Format(j, "00")
            .Refresh BackgroundQuery:=False
        End With
    Next j
    Next i
End Sub

swbuing

limonet 发表于 2022-12-9 13:35
代码在审核

谢谢老师，您的代码简单，我的基础有点差，还要好好消化一下。
但拆分的年度是由M1单元格决定的，不一定是2023，还可能是2024、2025等，再一个是能不能把代码加上注释，谢谢老师，辛苦了！！

limonet

把这一句替换
Set Rs = Cn.Execute("select * from [计算$A:J] where 应退年度=" & Worksheets("计算").Range("M1").Value & " and 应退月份=" & i)'条件是应退年度与应退月份
代码不长，你了解下SQL Select查询就明白了。

limonet

Sub a()
    Dim Cn As Object, Rs As Object, i%, j%
    Application.ScreenUpdating = False '关闭屏幕刷新
    Set Cn = CreateObject("adodb.connection") '建立ADO对象引用
    Cn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName '与本工作簿建立连接
    For i = 1 To 12
        Set Rs = Cn.Execute("select * from [计算$A:J] where 应退年度=" & Worksheets("计算").Range("M1").Value & " and 应退月份=" & i) '条件是应退年度与应退月份
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = i & "月" '新建工作表，并按月份命名
        For j = 0 To Rs.Fields.Count - 1
           Cells(1, j + 1) = Rs.Fields(j).Name '每个新工作表填充标题;也可以通过复制Worksheets("计算")的表头来实现
        Next j
        Range("A2").CopyFromRecordset Rs '把结果填充至以A2为左上角的区域，这是最想要的结果
    Next i
    Rs.Close '关闭rs
    Cn.Close '关闭cn
    Set Rs = Nothing '释放内存
    Set Cn = Nothing '释放内存
    Application.ScreenUpdating = True '打开屏幕刷新
End Sub

yanglinzi

蓝桥玄霜 发表于 2022-12-9 11:34
模块1代码：

工作表代码：

大师：kk=d(nf&"").keys要求对象。

swbuing

limonet 发表于 2022-12-9 21:17
Sub a()
    Dim Cn As Object, Rs As Object, i%, j%
    Application.ScreenUpdating = False '关闭屏 ...

谢谢大师！！