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、测试
最后,就是测试了,这次我们需要的代码比较多,大家在测试时可能会遇到各种问题,欢迎大家来找我问问题。
有了一键生成报表的能力,升职加薪,是不是变得简单了,大家能有更多的时间来做其他事情了。是不是特别的省事!