Question

在Excel中，我必须每月和每年添加分配给不同部门的时间。所以excel有1张12张纸，从1月到12月。它看起来像这样：（Jan）

同样的情况会在一年中的其他几个月重复出现。但分配的时间可能不同，有些部门可能根本没有提及。

我要做的任务是在不同月份添加分配给不同部门的所有时间，并将其显示在工作表上。沿线的东西：

最后在另一张表中，我必须为全年不同部门增加所有时间。沿线的东西：

我想知道有没有办法可以使用VBA脚本来实现这一目标。求助。

Answer 1

我的建议是以不同的方式设置Excel工作簿。一种明智的方法如下面的动画GIF所示。我只完成了前3个月的演示，并且我在第一部分的每个单元格中显示了公式，然后切换到最后显示结果。如果您以这种方式进行设置，则所需的所有结果将自动显示，而无需任何vba。如果您有疑问，请告诉我。

Answer 2

您需要另外两张纸。一个叫Monthly，另一个叫Yearly。假设数据从每张表中的A2开始（忽略标题）。

代码进入标准模块：

Option Explicit

Public Sub GetTimeAllocations()

    Dim wb As Workbook
    Dim monthsArr()

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set wb = ThisWorkbook
    monthsArr = Array("Jan", "Feb", "Mar", "Apr", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

    Dim monthDict As Object
    Dim wsMonthly As Worksheet
    Dim wsYearly As Worksheet

    Set monthDict = GetMonthDictionary(wb, monthsArr)
    Set wsMonthly = wb.Worksheets("Monthly")
    Set wsYearly = wb.Worksheets("Yearly")

    wsMonthly.UsedRange.ClearContents 'to clear out anything in sheet before writing to it
    wsYearly.UsedRange.ClearContents

    WriteOutData wsMonthly, wsYearly, monthDict

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    Dim lastRow As Long

    With ws

        lastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

    GetLastRow = lastRow

End Function
Public Function GetMonthDictionary(ByVal wb As Workbook, ByVal monthsArr As Variant) As Object

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim currentMonth As Long
    Dim monthDict As Object

    Set monthDict = CreateObject("Scripting.Dictionary")

    For currentMonth = LBound(monthsArr, 1) To UBound(monthsArr, 1)

        On Error Resume Next

        Set ws = wb.Worksheets(monthsArr(currentMonth))
        lastRow = GetLastRow(ws, 1)

        Dim valuesArr()
        valuesArr = ws.Range("A2:B" & lastRow).Value2

        Dim currentItem As Long

        For currentItem = LBound(valuesArr, 1) To UBound(valuesArr, 1)

            Dim monthDept As String
            Dim dept As String
            Dim hours As Double

            dept = Trim$(valuesArr(currentItem, 1))
            monthDept = ws.Name & "," & dept
            hours = CDbl(Split(Trim$(valuesArr(currentItem, 2)), " ")(0))

            If Not monthDict.Exists(monthDept) Then
                monthDict.Add monthDept, hours
                monthDict.Add dept, hours
            Else
                monthDict(monthDept) = monthDict(monthDept) + hours
                monthDict(dept) = monthDict(dept) + hours

            End If

        Next currentItem

        On Error GoTo 0

        Set ws = Nothing

    Next currentMonth

    Set GetMonthDictionary = monthDict

End Function

Public Sub WriteOutData(ByVal wsMonthly As Worksheet, ByVal wsYearly As Worksheet, ByVal monthDict As Object)

    Dim outputRow As Long
    Dim key As Variant

    For Each key In monthDict.Keys

        If InStr(1, key, ",") > 0 Then           'Month,Dept  Hours

            outputRow = outputRow + 1

            With wsMonthly

                .Cells(outputRow, 1).Resize(1, 2).Value = Split(key, ",")
                .Cells(outputRow, 3) = monthDict(key) & " hrs"

            End With

        Else                                     'Yearly figure Dept, Hours (total)

            With wsYearly

                .Cells(outputRow, 1) = key
                .Cells(outputRow, 2) = monthDict(key) & " hrs"

            End With

        End If

    Next key

End Sub

循环通过工作表并使用VBA计算总和

2 个答案: