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

swbuing

说明：这是导出的部分在职人员基本信息。当前筛选应退年度为2023

目标：根据产生分表的年度 拆分工作表，如
产生分表的年度 2023 ，意思是说　将应退年度为2023的人员，按应退月份拆分，分别产生一个新工作表，将应退月份为1的人员放在名称为“1月”的工作表，将应退月份为2的人员放在名称为“2月”的工作表；……共生成12个工作表。
当产生分表的年度 2024时，由此类推，产生2024年度的12个月的分表。

这是我在工作 中遇到的一个难题，恳请大师帮助，谢谢！！

fzxba

变成3种方法.rar (926.29 KB, 下载次数: 21)

2022-12-9 11:35 上传

点击文件名下载附件

蓝桥玄霜

模块1代码：

工作表代码：

ykcbf1100

总表拆分为新工作簿多表

ZHLK

Sub 宏1()
Dim sht As Worksheet
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

lele6809

ykcbf1100 发表于 2022-12-9 11:38
总表拆分为新工作簿多表

            If arr(i, 8) = nf Then 不应该是            If arr(i, 8) = yf Then

ykcbf1100

lele6809 发表于 2022-12-9 11:54
If arr(i, 8) = nf Then 不应该是            If arr(i, 8) = yf Then

你说的对，当时疏忽了。
4楼代码已更新。

limonet

代码在审核

limonet

Sub a()
    Dim Cn As Object, Rs As Object, i%, j%
    Application.ScreenUpdating = False
    Set Cn = CreateObject("adodb.connection")
    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 应退年度=2023 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
        Next j
        Range("A2").CopyFromRecordset Rs
    Next i
    Rs.Close
    Cn.Close
    Set Rs = Nothing
    Set Cn = Nothing
    Application.ScreenUpdating = True
End Sub

lkqsmxw

https://club.excelhome.net/forum ... DF8MTQxNDY4MQ%3D%3D