VBA提取重复区域指定值按行粘贴 适配不等长员工分组

VBasic2008此前提供的解决方案运行效果符合预期，但提交问题时遗漏了一项规则：名称列中all employees条目对应的数组大小与其他常规分组存在差异，需新增if判断逻辑修复该异常，异常情况参考下图：

具体处理规则：首个姓名对应的分组范围为A2:C7，需从该分组范围中提取姓名、岗位信息，以及B列的第2个、第5个数值，整理为单行数据写入目标位置；后续按相同逻辑循环处理其余人员及岗位对应的分组，相关参考截图如下：

Sub ArrangeDailyCumulations()

' 源表配置
Const sName As String = "Data Dump"
Const sfCol As String = "A"
Const sfRow As Long = 1
Const sTextColOffset As Long = 1
Const sNumbersCount As Long = 5
Dim sRowOffsets As Variant: sRowOffsets = VBA.Array(0, 0, 2, 5)
Dim sColOffsets As Variant: sColOffsets = VBA.Array(0, 1, 1, 1)
' 目标表配置
Const dName As String = "Daily Cumulations"
Const dfCol As String = "A"
Const dfRow As Long = 2
Dim dColOffsets As Variant: dColOffsets = VBA.Array(1, 0, 3, 2)
' 工作簿配置
Dim wb As Workbook: Set wb = ThisWorkbook ' 代码所在工作簿

' 引用源工作表并计算最后一行行号
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row

' 引用目标工作表、目标起始单元格，计算起始单元格到表尾的总行数
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dfCol)
Dim dwsrCount As Long: dwsrCount = dws.Rows.Count - dfCell.Row + 1

' 清空目标列原有数据
Dim oUpper As Long: oUpper = UBound(dColOffsets)
Dim o As Long
    
For o = 0 To oUpper
    dfCell.Offset(, dColOffsets(o)).Resize(dwsrCount).Clear
Next o

' 从源表读取数据写入目标表
Dim sCell As Range
Dim sr As Long
Dim dCell As Range
Dim ddrCount As Long

For sr = sfRow To slRow
    Set sCell = sws.Cells(sr, sfCol)
    If Not IsNumeric(sCell.Offset(, sTextColOffset)) Then ' 偏移列内容非数值，判定为分组起始行
        ddrCount = ddrCount + 1
        For o = 0 To oUpper
            dfCell.Offset(, dColOffsets(o)).Value _
                = sCell.Offset(sRowOffsets(o), sColOffsets(o)).Value
        Next o
        Set dfCell = dfCell.Offset(1)
        sr = sr + sNumbersCount
    'Else ' 单元格内容为数值或空值（VBA中空值也会判定为数值类）
    End If
Next sr

' 完成提示
MsgBox "已复制累计数据条数: " & ddrCount, vbInformation

End Sub

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