批量生成某时间段里每个人的绩效表

在工作中，从一个员工奖金明细表中，需要某一时段每人的绩效的Excel表格，这时需要批量生成每个员工的在这个时间段中的绩效，即每一个员工生成一个Excel表，再发给具体的每一个人。

    

    通过单击一个按钮，输出上图中的表格，效果是同时输出每一个员工的，如下图所示：

VBA代码:

        

'分组分阶段批量导出带格式的excel

'示例作者：仙来

'制作时间：2017-12-1

Private Sub cmdtoex_Click()

'必须引用 Microsoft Excel 14.0 Object Library或相应版本

    On Error GoTo err

    If IsNull(Me.begindat) Or IsNull(Me.enddat) Then

        MsgBox '日期不能为空！'

    End If

    Dim strSQL1, strSQL2 As String

    Dim rst1, rst2 As Object

    Dim strid As String

    Dim objxls As Object

    Dim lngNumber, N, L As Long

    strSQL1 = 'SELECT tblygjj.ygxm FROM tblygjj GROUP BY tblygjj.ygxm;'

    Set rst1 = CurrentDb.OpenRecordset(strSQL1, dbOpenDynaset)

    rst1.MoveFirst

    Do Until rst1.EOF

        '循环读取分组字段的值

        strid = rst1!ygxm

        'MsgBox strid

        strSQL2 = 'SELECT tblygjj.ygtxs, tblygjj.ygjjrq, tblygjj.ygxm, tblygjj.ygjjse, tblygjj.ygjjbz' _

            & ' FROM tblygjj' _

            & ' WHERE (((tblygjj.ygjjrq)>=#' & Me.begindat & '# And (tblygjj.ygjjrq)<=#' & Me.enddat & '#) AND ((tblygjj.ygxm)='' & strid & ''))' _

            & ' ORDER BY tblygjj.ygjjrq;'

        Set rst2 = CurrentDb.OpenRecordset(strSQL2, dbOpenDynaset)

        If rst2.RecordCount > 0 Then

            '如有数据则将游标指针移到最后一条记录

            rst2.MoveLast

            '获取记录集中的记录数

            lngNumber = rst2.RecordCount

            'MsgBox '符合条件的记录数有    ' & lngNumber & '   条', vbInformation, '提示'

        End If

        Set objxls = CreateObject('excel.Application')

        objxls.Workbooks.Add

        With objxls.Sheets('Sheet1')

            .Range('B1') = ' XX单位员工绩效明细表'

            .Range('B2') = '员工姓名：'

            .Range('C2') = strid

            .Range('D2') = '时 段：'

            .Range('E2') = Me.begindat & '至' & Me.enddat

            .Range('E2:F2').MergeCells = True

            .Range('E2:F2').HorizontalAlignment = xlCenter

            .Range('B3') = '日 期'

            .Range('C3') = '是否特岗'

            .Range('D3') = '绩  效'

            .Range('E3') = '备        注'

            .Range('E3:F3').MergeCells = True

            .Range('E3:F3').HorizontalAlignment = xlCenter

            N = 4

            L = N lngNumber

            rst2.MoveFirst

            Do While Not rst2.EOF

                .Range('B' & N) = rst2('ygjjrq')

                .Range('B' & N).NumberFormatLocal = 'yyyy-m'

                .Range('C' & N) = IIf(rst2('ygtxs') = True, '是', '')

                .Range('D' & N) = rst2('ygjjse')

                .Range('D' & N).NumberFormatLocal = '￥#,##0.00_);(￥#,##0.00)'

                .Range('E' & N) = rst2('ygjjbz')

                '注意变量行的表示方法

                .Range('E' & N & ':' & 'F' & N).MergeCells = True

                rst2.MoveNext

                N = N 1

            Loop

            .Range('C' & L) = '绩效合计：'

            .Range('D' & L) = DSum('ygjjse', 'tblygjj', 'ygxm ='' & strid & '' AND ygjjrq>=#' & Me.begindat & '# And ygjjrq<=#' & Me.enddat & '# ')

            .Range('D' & L).NumberFormatLocal = '￥#,##0.00_);(￥#,##0.00)'

            .Range('D' & L).Font.Color = -16776961

            .Range('B' & L 1) = '制表：'

            .Range('E' & L 1) = '制表日期：'

            .Range('F' & L 1) = Date

            .Range('F' & L 1).NumberFormatLocal = 'yyyy-m-d'

            .Range('A1').RowHeight = 64.5

            .Range('A2:A' & L 1).RowHeight = 21.75

            With .Range('B1:F1')

                .ColumnWidth = 14

                .MergeCells = True

                .HorizontalAlignment = xlCenter

                .VerticalAlignment = xlBottom

                .Font.Size = 16

                .Font.ThemeColor = xlThemeColorLight1

                .Font.ThemeFont = xlThemeFontMinor

                .Font.Bold = True

            End With

            With .Range('B2:D' & L - 1)

                .HorizontalAlignment = xlCenter

            End With

            '注意带有变量行，多区域表示法

            .Range('C' & L & ',' & 'B' & L 1 & ',' & 'E' & L 1).HorizontalAlignment = xlRight

            .Range('B3' & ':' & 'F' & L - 1).Borders.LineStyle = xlContinuous

        End With

        objxls.Visible = True

        Dim myDateRange As String

        '格式化日期区间，避免日期中带/号而违反文件名命名规则

        myDateRange = Format(Me.begindat, 'YYYYMMDD') & '-' & Format(Me.enddat, 'YYYYMMDD')

        '生成EXCEL文件

        objxls.ActiveWorkbook.SaveAs FileName:=CurrentProject.Path & '\' & strid & '绩效表' & myDateRange & '.xls'

        Set objxls = Nothing

        Set rst2 = Nothing

        rst1.MoveNext

    Loop

    rst1.MoveFirst

    Set rst1 = Nothing

err:         Exit Sub

End Sub