动态生成车间生产日报表

tycp

车间生产日报表.zip (4.13 KB, 下载次数: 5437)

2013-5-31 12:37 上传

点击文件名下载附件
EXCEL模板

最近，为了验厂，人事要我准备3个月的车间生产日报表，但我们车间根本就没有记录，怎么办？人事要我瞎编，但如果用手工写的话，估计要累死，本人从来不喜欢做这种重复又很累的工作，于是花了一晚上的时间，写成了这个程序，几分钟就生成了三个月的车间生产日报表，附件是车间生产日报表的模板！
[code=vb]
Private Sub Command1_Click()
Dim MyExcel As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlSheet1 As Excel.Worksheet
Dim i As Long
Dim j As Long
Dim x As Integer
Dim y As Integer
Dim dx As Integer
Dim cl As Integer
Dim jwz As Integer
Dim yb As Integer
Dim gx(1 To 4) As String '工序
gx(1) = "包装"
gx(2) = "磨光"
gx(3) = "钻床"
gx(4) = "油机"
Set MyExcel = CreateObject("Excel.Application")
MyExcel.Visible = False
Set xlBook = MyExcel.Workbooks.Open("F:\车间生产日报表.xls")
Set xlSheet = xlBook.Sheets("Sheet1")
Set xlSheet1 = xlBook.Sheets("Sheet2")
For i = 1 To 68
xlSheet.Range("a1:h31").Copy Destination:=xlSheet.Range("a" & i * 31 + 1)
Next
j = xlSheet.Range("a65536").End(xlUp).Row
For i = 1 To j
xlSheet.Rows(i).RowHeight = 21
Next
For i = 0 To 69
xlSheet.Rows(i * 31 + 1).RowHeight = 48
Next
Dim arr(1 To 29, 1 To 7) As String
Dim arru(1 To 29) As Boolean
Dim jx As Boolean
Dim arrd(1 To 69) As String
For i = 1 To 29
arr(i, 1) = xlSheet1.Cells(i, 1).Value
arr(i, 2) = xlSheet1.Cells(i, 2).Value
arr(i, 3) = xlSheet1.Cells(i, 3).Value
arr(i, 4) = xlSheet1.Cells(i, 4).Value * 2
arr(i, 5) = xlSheet1.Cells(i, 4).Value * 3
arr(i, 6) = xlSheet1.Cells(i, 4).Value * 3
arr(i, 7) = xlSheet1.Cells(i, 4).Value * 3
Next
For i = 1 To 69
arrd(i) = xlSheet1.Cells(i, 5).Value
Next
For i = 1 To 69
jwz = (i - 1) * 31 + 4
jwz1 = 0
xlSheet.Cells(jwz - 2, 6).Value = arrd(i)
xlSheet.Cells(jwz + 27, 1).Value = IIf(i < 48, "填表：XXX", "填表：YYY")
For j = 1 To 29
arru(j) = False
Next
For j = 1 To 4

yb = Int(Rnd * 2) + 1
For x = 1 To yb
Randomize
cl = Int(Rnd * 100) + IIf(j = 1, 135, 255) + IIf(j = 1, Int(i / 30 * 80), Int(i / 30 * 150))
For y = 1 To 26
If arru(y + j - 1) = False Then
If arr(y + j - 1, j + 3) - 58 >= cl Then
xlSheet.Cells(jwz + x - 1 + jwz1, 1).Value = arr(y + j - 1, 1)
xlSheet.Cells(jwz + x - 1 + jwz1, 3).Value = arr(y + j - 1, 2)
xlSheet.Cells(jwz + x - 1 + jwz1, 4).Value = arr(y + j - 1, 3)
xlSheet.Cells(jwz + x - 1 + jwz1, 5).Value = gx(j)
xlSheet.Cells(jwz + x - 1 + jwz1, 6).Value = cl
arr(y + j - 1, j + 3) = arr(y + j - 1, j + 3) - cl
arru(y + j - 1) = True
Exit For
End If
If arr(y + j - 1, j + 3) > 0 Then
xlSheet.Cells(jwz + x - 1 + jwz1, 1).Value = arr(y + j - 1, 1)
xlSheet.Cells(jwz + x - 1 + jwz1, 3).Value = arr(y + j - 1, 2)
xlSheet.Cells(jwz + x - 1 + jwz1, 4).Value = arr(y + j - 1, 3)
xlSheet.Cells(jwz + x - 1 + jwz1, 5).Value = gx(j)
xlSheet.Cells(jwz + x - 1 + jwz1, 6).Value = arr(y + j - 1, j + 3)
arr(y + j - 1, j + 3) = 0
arru(y + j - 1) = True
Exit For
End If
End If
Next
Next
jwz1 = jwz1 + yb
Next
Next
xlBook.Save
xlBook.Close
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlSheet1 = Nothing
Set MyExcel = Nothing
MsgBox "ok"
End Sub
Private Sub Command2_Click()
Dim MyExcel As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlBook3 As Excel.Workbook
Dim xlBook4 As Excel.Workbook
Dim xlBook5 As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlSheetN As Excel.Worksheet
Dim i As Integer
Dim m As Integer
Set MyExcel = CreateObject("Excel.Application")
MyExcel.Visible = False
Set xlBook = MyExcel.Workbooks.Open("F:\车间生产日报表.xls")
Set xlBook3 = MyExcel.Workbooks.Open("F:\3月份车间生产日报表.xls")
Set xlBook4 = MyExcel.Workbooks.Open("F:\4月份车间生产日报表.xls")
Set xlBook5 = MyExcel.Workbooks.Open("F:\5月份车间生产日报表.xls")
Set xlSheet = xlBook.Sheets("Sheet1")
For i = 0 To 67
m = Month(xlSheet.Cells(i * 31 + 2, 6).Value)
If m = 3 Then
Set xlSheetN = xlBook3.Worksheets.Add
xlSheetN.Name = xlSheet.Cells(i * 31 + 2, 6).Value
End If
If m = 4 Then
Set xlSheetN = xlBook4.Worksheets.Add
xlSheetN.Name = xlSheet.Cells(i * 31 + 2, 6).Value
End If
If m = 5 Then
Set xlSheetN = xlBook5.Worksheets.Add
xlSheetN.Name = xlSheet.Cells(i * 31 + 2, 6).Value
End If
xlSheet.Range("a" & (i * 31 + 1) & ":h" & (i + 1) * 31).Copy Destination:=xlSheetN.Range("a1:h31")
Next
xlBook3.Save
xlBook4.Save
xlBook5.Save
Set xlBook3 = Nothing
Set xlBook4 = Nothing
Set xlBook5 = Nothing
Set xlSheetN = Nothing
Set xlSheet = Nothing
Set MyExcel = Nothing
MsgBox "ok"
End Sub

[/code]

szrunstar1

好贴，下载学习了，努力奋斗中

塞牙

vba还真的很强大！

xiaoqing87316

晕！excel还能造假！{:soso_e128:}

大楚國民

很好，很强大

dqnie

学习一下，感谢分享

小风叶

感谢分享。。。

wangxinbing

看不懂哦……

nanjixue

楼主很强大，学习了，效率是杠杠的。巧妙，造假原来也可以这么简单{:soso_e113:}

永恒的神话_

学习一下，感谢分享