VBA编程源码下载，产量统计，月度生产报表统计

产量记录管理，本文内容中关于产量录入，统计的一些基本功能。

如需要，可及时收藏备用。

上图为录入页，形式简单只有相关人员日期和数量，如果需要可以再进行添加。

上图为统计表，可以对某人的某个月进行记录统计，实际上也算一个查询的功能。

上图为月度统计表。

每月统计数据实现统计计算。

代码

数据录入

Sub 录入信息()
On Error Resume Next
Dim xArr(1 To 4)
xArr(1) = Range("D3").Value
xArr(2) = Range("F3").Value
xArr(3) = Range("D4").Value
xArr(4) = Range("F4").Value
Dim s As Worksheet
Set s = ThisWorkbook.Worksheets("产量统计表")
Dim ir As Integer, ic As Integer
ir = 3
ic = 4
s.Cells(ir, 1).Resize(1, ic).Insert shift:=xlShiftDown
With s.Cells(ir, 1).Resize(1, ic)
    .Clear
    .ClearFormats
    .RowHeight = 18
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Borders.LineStyle = 1
    .Item(1).NumberFormat = "yyyy/mm/dd"
    .Value = xArr
End With
ir = s.Cells(s.Rows.Count, 1).End(xlUp).Row
s.Cells(ir, 3).Formula = "=Sum(C3:C" & ir - 1 & ")"
s.Cells(ir, 4).Formula = "=Sum(D3:D" & ir - 1 & ")"
Set s = Nothing
Erase xArr
End Sub

个人统计

Sub 个人搜索()
On Error Resume Next
Dim xName As String, xCountA As Double, xCountB As Double, xMouth As Integer
Dim s As Worksheet
Set s = ActiveSheet
DelCells s
xName = VBA.UCase(VBA.Trim(Range("F2").Value))
If VBA.Len(xName) = 0 Then Exit Sub
If Not VBA.IsNumeric(s.Range("F3").Value) Then MsgBox "月份错误！请输入1~12之间数字": Exit Sub
xMouth = Range("F3").Value
If xMouth > 12 Then MsgBox "月份错误！请输入1~12之间数字": Exit Sub
Dim xR As Range, r As Range
 Dim xArr, ir As Long, ic As Long, i As Long, eir As Long
 xArr = s.Range("A2").CurrentRegion
ir = UBound(xArr, 1)
ic = 2
For i = LBound(xArr, 1) + 1 To ir
    If VBA.IsDate(xArr(i, 1)) Then
        If xMouth = VBA.DatePart("m", xArr(i, 1)) Then
                    If VBA.DatePart("d", xArr(i, 1)) <= 26 Then
                        If VBA.UCase(xArr(i, 2)) = xName Then
                            xCountA = xCountA + VBA.CDbl(xArr(i, 3))
                            xCountB = xCountB + VBA.CDbl(xArr(i, 4))
                            AddCells xArr, s, i
                        End If
                    End If
        ElseIf xMouth - 1 = VBA.DatePart("m", xArr(i, 1)) Then
                    If VBA.DatePart("d", xArr(i, 1)) > 26 Then
                        If VBA.UCase(xArr(i, 2)) = xName Then
                            xCountA = xCountA + VBA.CDbl(xArr(i, 3))
                            xCountB = xCountB + VBA.CDbl(xArr(i, 4))
                            AddCells xArr, s, i
                        End If
                    End If
        End If
    End If
Next i
    eir = s.Range("G" & s.Rows.Count).End(xlUp).Row
    eir = eir + 1
    If eir > 2 Then
        s.Range("G" & eir).Value = "合计"
        s.Range("H" & eir).Value = xName
        s.Range("I" & eir).Value = xCountA
        s.Range("J" & eir).Value = xCountB
    End If
    With s.Range("G3:J" & eir)
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 20
    End With
Erase xArr
Set s = Nothing
End Sub

月度汇总

Sub 月度汇总()
On Error Resume Next
Dim xCountA As Double, xCountB As Double, xMouth As Integer
Dim s As Worksheet, c As Worksheet, j As Worksheet, jr As Long
Set s = ThisWorkbook.Worksheets("设置")
Set c = ThisWorkbook.Worksheets("产量统计表")
Set j = ActiveSheet
j.Cells(3, 1).Resize(j.UsedRange.Rows.Count - 2, 4).Delete
If Not VBA.IsNumeric(s.Range("E1").Value) Then Exit Sub
xMouth = Range("E1").Value
Dim xArr, xi As Long, ir As Long, ic As Long
xArr = c.Range("A2").CurrentRegion
ir = UBound(xArr, 1)
ic = 2
Dim sArr, si As Long, sr As Long
sr = s.Cells(1, 1).End(xlDown).Row
sArr = s.Range("A2:A" & sr)
sr = UBound(sArr, 1)
For si = LBound(sArr, 1) To sr
                                        xCountA = 0
                                        xCountB = 0
    For xi = LBound(xArr, 1) To ir
        If VBA.UCase(xArr(xi, ic)) = VBA.UCase(sArr(si, 1)) Then        "如果姓名相同
                 If VBA.IsDate(xArr(xi, 1)) Then
                     If xMouth = VBA.DatePart("m", xArr(xi, 1)) Then
                                If VBA.DatePart("d", xArr(xi, 1)) <= 26 Then
                                        xCountA = xCountA + VBA.CDbl(xArr(xi, 3))
                                        xCountB = xCountB + VBA.CDbl(xArr(xi, 4))
                                End If
                    ElseIf xMouth - 1 = VBA.DatePart("m", xArr(xi, 1)) Then
                               If VBA.DatePart("d", xArr(xi, 1)) > 26 Then
                                        xCountA = xCountA + VBA.CDbl(xArr(xi, 3))
                                        xCountB = xCountB + VBA.CDbl(xArr(xi, 4))
                                End If
                    End If
                End If
        End If
    Next xi
    jr = j.Cells(j.Rows.Count, 1).End(xlUp).Row + 1
    j.Cells(jr, 1).Value = "=row()-2"
    j.Cells(jr, 2).Value = sArr(si, 1)
    j.Cells(jr, 3).Value = xCountA
    j.Cells(jr, 4).Value = xCountB
    With j.Cells(jr, 1).Resize(1, 4)
        .RowHeight = 18
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Next si
j.Range("A1").Value = xMouth & "月度汇总表"
Erase xArr
Set j = Nothing
Set s = Nothing
Set c = Nothing
End Sub

产量统计也是一个重要的环节，特别是一些中小型企业，生产密集型企业更是需要一个高效的统计表来进行结算。

如有需要可以查看产量统计表，Excel vba。

欢迎关注、收藏

---END---