生产信息系统报表分析功能（三）

Hi，手机边亲爱的你还好吗！

今天我们接着来讲一下生产信息系统报表分析功能，今天我们要讲是最后一步，如何生成对应的excel报表。也是最重要的一步，且代码量是最多的一步。

我们再来看一下我们需要生成的excel报表。

我们可以看到，我们最完成的报表相对来说是比较麻烦的，如果要手工来算的话是比较繁琐的，有的同学会说了，这个excel报表太简单了，我一天能做好几个！确实，我们有很多的Access爱好者都是excel高手，一天能做好几个复杂的报表，但是，但是我们这个报表如果是每周都要输出呢？或者每月，或者我要取一个范围呢？这样是不是就比较麻烦了。而现在，我们只需要点选几个条件范围，最后点一按钮就可以，短短几秒做到办公自动化。好的，接下去我们来看一下怎么操作。

01、添加导出按钮

在之前的窗体上添加导出按钮，按钮命名为cmd_Export

02、添加代码

这次的代码比较长，大家可以直接复制使用

Private Sub cmd_Export_Click()
On Error GoTo ErrorHandler
    Dim strTemplate As String
    Dim strPathName As String
    Dim objApp As Object
    Dim objBook As Object
    Dim objSheet As Object
    Dim rst As Object
    Dim intCounter As Integer
    Dim blnNoQuit As Boolean
    Dim strSQL, strmsg As String
    Dim strAsc, strAsc2 As String
    Dim objRange As Object
    Dim strSheetName As String
    Dim Gsum, SSum, Asum, Fsum, k, j, intColumn As Long
    If Me.frmChild.Form.CurrentRecord < 1 Then
        Exit Sub
    End If

    '默认保存的文件名
    strPathName = Me.Department & "报告.xls"

    '通过文件对话框取得另存为文件名
    With FileDialog(2)    'msoFileDialogSaveAs
        .InitialFileName = strPathName
        If .Show Then
            strPathName = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    '如果文件名后没有.xls扩展名则加上
    If Not strPathName Like "*.xls" Then strPathName = strPathName & ".xls"
    If Dir(strPathName) <> "" Then Kill strPathName    '删除已有文件
      DoCmd.Hourglass True
    '创建Excel对象
    Set objApp = CreateObject("Excel.Application")
    '新建sheet表
    Set objBook = objApp.Workbooks.Add
    Set objSheet = objBook.Worksheets.Add

    objSheet.Name = Me.Department
    objSheet.Select
    strSQL = "select * from TMP_Report"
    Set rst = CurrentDb.OpenRecordset(strSQL)
    If rst.RecordCount > 0 Then
        rst.MoveFirst
    End If
    'SHEET表第一列部分 总数量,报废数量,合格率,一次通过率,报废率
    objApp.Range("A1") = "生产报告"
    objApp.Range("A1").Font.Bold = True
    objApp.Range("A2") = "星期"
    objApp.Range("A2").Font.Bold = True
    objApp.Range("A3") = "日期"
    objApp.Range("A3").Font.Bold = True
    objApp.Range("A4") = "总数量"
    objApp.Range("A5") = "报废数量"
    objApp.Range("A6") = "合格率"
    objApp.Range("A7") = "一次通过率"
    objApp.Range("A8") = "报废率"
    Set objRange = objApp.Range("A4:A8")
    objRange.Select
    With objRange
        .RowHeight = 15
        .EntireColumn.AutoFit
        .WrapText = True
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlRight
    End With
    Set objRange = objApp.Range("A1:A8")    '加上边框
    objRange.Select
    With objRange
        .Font.Name = "Arial"
        .Font.Size = 10
        .Borders(xlEdgeLeft).LineStyle = xlContinuous  'xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        '        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    '添加第二列的目标值
    objApp.Range("B3") = "目标"
    objApp.Range("B3").Font.Bold = True
    objApp.Range("B1") = "周"
    objApp.Range("B4") = 1200
    objApp.Range("B5") = 5
    objApp.Range("B6") = Format(0.98, "Percent")
    objApp.Range("B7") = Format(0.95, "Percent")
    objApp.Range("B8") = Format(0.02, "Percent")
'    intColumn = 0
    j = 65
    k = 64
    strAsc = Chr(67 + intColumn)
'循环添加每一天的数据
    Do Until rst.EOF
        objApp.Range(strAsc & "1") = Format(rst!ProductionDate, "WW")
        objApp.Range(strAsc & "2") = Format(rst!ProductionDate, "dddd")
        objApp.Range(strAsc & "3") = Format(rst!ProductionDate, "YYYY-MM-DD")
        objApp.Range(strAsc & "4") = rst!总数量
        If objApp.Range(strAsc & "4") < objApp.Range("B4") Then
            objApp.Range(strAsc & "4").Interior.Color = 255
        Else
            objApp.Range(strAsc & "4").Interior.Color = 16744448
        End If
        objApp.Range(strAsc & "5") = rst!报废数量
        If objApp.Range(strAsc & "5") > objApp.Range("B7") Then
            objApp.Range(strAsc & "5").Interior.Color = 255
        Else
            objApp.Range(strAsc & "5").Interior.Color = 16744448
        End If
        objApp.Range(strAsc & "6") = Format(rst!合格率, "Percent")
        If objApp.Range(strAsc & "6") < objApp.Range("B6") Then
            objApp.Range(strAsc & "6").Interior.Color = 255
        Else
            objApp.Range(strAsc & "6").Interior.Color = 16744448
        End If
        objApp.Range(strAsc & "7") = Format(rst!一次通过率, "Percent")
        If objApp.Range(strAsc & "7") < objApp.Range("B7") Then
            objApp.Range(strAsc & "7").Interior.Color = 255
        Else
            objApp.Range(strAsc & "7").Interior.Color = 16744448
        End If
        objApp.Range(strAsc & "8") = Format(rst!报废率, "Percent")
        If objApp.Range(strAsc & "8") > objApp.Range("B8") Then
            objApp.Range(strAsc & "8").Interior.Color = 255
        Else
            objApp.Range(strAsc & "8").Interior.Color = 16744448
        End If

        If intColumn >= 23 Then
            If k >= 89 Then
                k = 65
                j = j + 1
            Else
                k = k + 1
            End If
            strAsc = Chr(j) & Chr(k)
        Else
            intColumn = intColumn + 1
            strAsc = Chr(67 + intColumn)
        End If
        rst.MoveNext
    Loop
    If intColumn >= 23 Then
        If k >= 89 Then
            k = 65
            j = j + 1
        Else
            k = k + 1
        End If
        strAsc2 = Chr(j) & Chr(k)
    Else
        intColumn = intColumn - 1
        strAsc2 = Chr(67 + intColumn)
    End If
    '最后一列统计部分
    If Len(strWhere) > 0 Then strWhere = Right(strWhere, Len(strWhere) - 7)
    If Me.Department = "所有部门" Then
        Fsum = DSum("FTGoodsQty", "qry_生产信息", strWhere)
        Gsum = Fsum + DSum("Rework", "qry_生产信息", strWhere)
    Else
        '一次通过总数量
        Fsum = DSum("FTGoodsQty", "qry_生产信息", "Department='" & Me.Department & "' and " & strWhere)
        '合格数量
        Gsum = Fsum + DSum("Rework", "qry_生产信息", "Department='" & Me.Department & "' and " & strWhere)

    End If

    SSum = DSum("报废数量", "TMP_Report")
    Asum = DSum("总数量", "TMP_Report")
    objApp.Range(strAsc & "2") = "合计"
    objApp.Range(strAsc & "2").Font.Bold = True
    objApp.Range(strAsc & "4") = "=sum(C4:" & strAsc2 & "4)"
    '添加格式
    If objApp.Range(strAsc & "4") < objApp.Range("B4") Then
        objApp.Range(strAsc & "4").Interior.Color = 255
    Else
        objApp.Range(strAsc & "4").Interior.Color = 16744448
    End If
    objApp.Range(strAsc & "5") = "=sum(C5:" & strAsc2 & "5)"
    If objApp.Range(strAsc & "5") > objApp.Range("B5") Then
        objApp.Range(strAsc & "5").Interior.Color = 255
    Else
        objApp.Range(strAsc & "5").Interior.Color = 16744448
    End If
    objApp.Range(strAsc & "6") = Format(Gsum / Asum, "Percent")
    If objApp.Range(strAsc & "6") < objApp.Range("B6") Then
        objApp.Range(strAsc & "6").Interior.Color = 255
    Else
        objApp.Range(strAsc & "6").Interior.Color = 16744448
    End If
    objApp.Range(strAsc & "7") = Format(Fsum / Asum, "Percent")
    If objApp.Range(strAsc & "7") < objApp.Range("B7") Then
        objApp.Range(strAsc & "7").Interior.Color = 255
    Else
        objApp.Range(strAsc & "7").Interior.Color = 16744448
    End If
    objApp.Range(strAsc & "8") = Format(SSum / Asum, "Percent")
    If objApp.Range(strAsc & "8") > objApp.Range("B8") Then
        objApp.Range(strAsc & "8").Interior.Color = 255
    Else
        objApp.Range(strAsc & "8").Interior.Color = 16744448
    End If

    '设置整体格式
    Set objRange = objApp.Range("B1:" & strAsc & 8)
    objRange.Select
    With objRange
        .RowHeight = 15
        .EntireColumn.AutoFit
        .WrapText = True
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
     '   .HorizontalAlignment = xlLeft
        .Font.Name = "Microsoft YaHei"
        .Font.Size = 10
        .Borders(xlEdgeLeft).LineStyle = xlContinuous  'xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    objApp.Range("A1").Select
    objBook.SaveAs strPathName
    DoCmd.Hourglass False
    Beep
    strmsg = "导出已完成，是否打开导出的Excel文件？"
    If MsgBox(strmsg, vbQuestion + vbYesNo, "导出完成") = vbYes Then
        objApp.Visible = True
        objBook.Saved = True
        blnNoQuit = True
        '自动进入打印预览
        'objApp.ActiveWindow.SelectedSheets.PrintPreview
    End If

Done:

    On Error Resume Next
    If Not blnNoQuit Then
        objBook.Saved = True
        objApp.Quit
    End If
    Set objApp = Nothing
    Set objBook = Nothing
    Set rst = Nothing
    Exit Sub

ErrorHandler:        '错误处理程序
    If Err = 70 Then
        strmsg = "不能替换文件，因为无法删除已有文件，可能的原因有：" & vbCrLf & vbCrLf & _
                 "1.该文件处于打开状态。" & vbCrLf & _
                 "2.没有对此目录的写入权限。"
    Else
        strmsg = Err.Description
    End If
    strmsg = "错误号：" & Err & vbCrLf & _
             "错误源：" & Err.Source & vbCrLf & _
             "错误描述：" & strmsg
    MsgBox strmsg, vbCritical, "出错"
    Resume Done
End Sub

03、测试

最后，就是测试了，这次我们需要的代码比较多，大家在测试时可能会遇到各种问题，欢迎大家来找我问问题。

有了一键生成报表的能力，升职加薪，是不是变得简单了，大家能有更多的时间来做其他事情了。是不是特别的省事！