如何改进VBA实现按规则拆分数据并按周一为起始周汇总

示例数据 #

初始数据

Table 1                         Names
Type    Start       End         XXX     XYZ
A       2024-10-31  2024-11-13  48.25   47
B       2024-11-05  2024-11-14  0.75    80.5
C       2024-10-31  2024-10-31          5

目标结果

Table 2         
Type    Name    2024-10-28  2024-11-04  2024-11-11
A       XXX     9.75        23.75       14.75
A       XYZ     9.5         23.25       14.25
B       XXX     0           0.25        0.5
B       XYZ     0           40.25       40.25
C       XYZ     5           0           0

需求目标 #

这类似于unpivot（逆透视）操作：将数值按指定倍数拆分，先将基准倍数分配到所有工作日，剩余数值从起止日期向内分配，最后按周一为起始的周进行汇总。

注意：数值除以指定倍数后必为整数；
Table1位于其他工作簿的单元格区域；
Table2为本工作簿中的命名表格（已定义为ListObject）；
当前暂不考虑节假日因素。

已梳理的步骤 #

• 将数值除以工作日天数
• 按指定倍数向下取整得到基准日值
• 计算剩余数值
• 确定需要分配额外数值的工作日数量
• 将额外数值的工作日平均分配到起止日期，若数量为奇数则结束日期多分配1天
• 为所有工作日分配基准日值
• 为起始端的额外工作日分配倍数数值
• 为结束端的额外工作日分配倍数数值
• 按对应周汇总数值
• 将结果填入目标表格中对应Type-Name组合与日期的交叉位置

现有代码 #

以下是正在开发的未完成代码，后半部分（888循环之后）需彻底重构：

Private Sub LoadPPT_Click()

Dim frm As PPT_Picker_Form
Dim wbPPT As Workbook
Dim wsPPT As Worksheet
Dim rngTopLeft As Range, rngBotRight As Range, rngPPTTable As Range
Dim lngLastUsedRow As Long
Dim lngLastCol As Long
Dim rngTargetCell As Range
Dim rngNameRow As Range
Dim rngNameCellFirst As Range, rngNameCellLast As Range
Dim lngTimeStart As Long
Dim rngStartDateCol As Range
Dim rngEndDateCol As Range
Dim rngHours As Range
Dim InputTable As ListObject
Dim lngInsertRow As Long
Dim lngPPTRowCounter As Long
Dim lngPPTColCounter As Long
Dim dStartDate As Date
Dim dEndDate As Date
Dim lngWeeks As Long
Dim dTaskSM As Date
Dim dTaskEM As Date
Dim lngTaskDays As Long
Dim dbTaskHoursPerDay As Double
Dim dbTaskDayUnits As Double
Dim dbTaskExtraUnitDays As Long
Dim lngDayCoutner As Long
Dim TestDate As Date
Dim dbWeek1Hours As Double
Dim dbWeeknHours As Double
Dim dbWeekLhours As Bouble



'Public strPPTFilepath As String
'Public strProjectNumber As String
    Set InputTable = Me.ListObjects("Forecast_Table")
    
    Set frm = UserForms.Add(PPT_Picker_Form.Name)
    frm.ListData = ThisWorkbook.Worksheets("Project Numbers").ListObjects("Project_Number_List").DataBodyRange
    
    frm.show
        
    If bCancelled Then
        Exit Sub
    End If
    
    'Define PPT Table
        
    Set wbPPT = Workbooks.Open(strPPTFilepath)
    Set wsPPT = wbPPT.Worksheets("Fee Estimate")
    
    'Find top left corner
    With wsPPT.Cells
        Set rngTopLeft = .Find("WBS Code", LookIn:=xlFormulas)
        
        If rngTopLeft Is Nothing Then
            'nothing found
            'add a manual cell picker routine
        End If
        
        Set rngTopLeft = rngTopLeft.Offset(2, 0)
    End With
    
    'Find last row
    lngLastUsedRow = wsPPT.Cells(wsPPT.Rows.count, rngTopLeft.Column).End(xlUp).Row
    
    'find Right edge
    With wsPPT.Cells
        Set rngTargetCell = .Find("Name", LookIn:=xlFormulas, LookAt:=xlWhole)
        'Assume first name is to the right of the cell containing "Name"
        Set rngNameCellFirst = rngTargetCell.Offset(0, 1)
                
        If rngTargetCell Is Nothing Then
            'nothing found
            'add a manual cell picker routine
        End If
        
        Do While rngTargetCell <> ""
            Set rngTargetCell = rngTargetCell.Cells.Offset(0, 1)
            lngLastCol = rngTargetCell.Column
        Loop
            
        Set rngNameCellLast = rngTargetCell.Cells.Offset(0, -1)
        lngLastCol = lngLastCol - 1
            
        Set rngTargetCell = .Find("Start Date", LookIn:=xlFormulas, LookAt:=xlWhole)
        Set rngStartDateCol = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngTargetCell.Column))
        
        Set rngTargetCell = .Find("End Date", LookIn:=xlFormulas, LookAt:=xlWhole)
        Set rngEndDateCol = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngTargetCell.Column))
        
        Set rngTargetCell = .Find("Units", LookIn:=xlFormulas, LookAt:=xlWhole)
        Set rngHours = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngNameCellLast.Column))
        
    End With
    
    'Define PPT table
    Set rngPPTTable = wsPPT.Range(rngTopLeft, wsPPT.Cells(lngLastUsedRow, lngLastCol))
    Set rngNameRow = wsPPT.Range(rngNameCellFirst, rngNameCellLast)
    
    InsertRow = TableLastUsedRow
    
   ' strProjectNumber
    If InputTable.ListRows(InputTable.ListRows.count).Range.Row = InsertRow Then
        InputTable.ListRows.Add AlwaysInsert:=True
        InsertRow = InsertRow + 1
    End If
    
    
        
        For lngPPTRowCounter = 1 To 888
            If WorksheetFunction.CountA(rngPPTTable.Row(lngPPTRowCounter)) <> 0 Then
                InputTable.ListColumns("Project No").ListRow(InsertRow) = strProjectNumber
                InputTable.ListColumns("Task No").ListRow(InsertRow) = rngPPTTable.Cells(PPTRowCounter, 2) & " - " & rngPPTTable.Cells(PPTRowCounter, 3)
                InputTable.ListColumns("Staff").ListRow(InsertRow) = rngNameRow(PPTColCounter)
                'Insert Funtcion to fill in Office Based on Name
                dStartDate = rngStartDate(rngPPTRowCounter)
                dEndDate = rngEndDate(rngPPTRowCounter)
                dTaskSM = Monday_Date(dStartDate)
                dTaskEM = Monday_Date(dEndDate)
                lngTaskDays = WorksheetFunction.NetworkDays(dStartDate, dEndDate)
                
                For lngPPTColCounter = 1 To 999
                    If rngHours(lngPPTRowCounter, lngPPTColCounter) > 0 Then
                        dbTaskHoursPerDay = WorksheetFunction.RoundDown((rngHours(lngPPTRowCounter, lngPPTColCounter) / lngTaskDays) / 0.25, 0) * 0.25
                        If dbTaskHoursPerDay = 0 Then
                            'Outside in fill to 0 routine
                        Else
                        dbTaskDayUnits = rngHours(lngPPTRowCounter, lngPPTColCounter) / dbTaskHoursPerDay
                        dbTaskExtraUnitDays = dbTaskDayUnits Mod lngTaskDays
                        
                        TestDate = dStartDate
                        
                        For lngDayCounter = 1 To (dEndate - dStartDate)
                            If Weekday(TestDate) > 1 And Weekday(TestDate) < 7 Then
                                If TestDate < dTaskSM + 5 Then
                                    Week1hours= Week1Hours+
                                ElseIf TestDate < dTaskEM - 2 Then
                                
                                Else
                                
                            End If
                        
                        
                        
                        Week1EndDate
                        Week2ndLastEndDate
                         
                        
                    End If
            End If
        
        
        Next lngPPTRowCounter
    Next lngPPTColCounter
    
End Sub

技术问询 #

如何改进当前的VBA实现方案，以完成从Table1到Table2的数据转换需求？

内容的提问来源于stack exchange，提问作者Forward Ed