Excel VBA遍历DataTable并填充季度日程表问题求助

以下是修正后的完整VBA代码，解决了遍历DataTable行和动态合并单元格的问题：

Sub ProcessDataTableRows()
    Application.ScreenUpdating = False
    
    Dim dtSheet As Worksheet
    Dim qsSheet As Worksheet
    Dim dtTable As ListObject
    Dim currentRow As ListRow
    Dim rangeID As Variant
    Dim startDate As Variant
    Dim totalDays As Long
    Dim statusDetail As String
    Dim foundRow As Range
    Dim foundCol As Range
    Dim targetCell As Range
    
    ' 初始化工作表和表格对象
    Set dtSheet = ThisWorkbook.Sheets("Data Table")
    Set qsSheet = ThisWorkbook.Sheets("Quarter Schedule")
    Set dtTable = dtSheet.ListObjects("DataTable")
    
    ' 遍历DataTable的每一行
    For Each currentRow In dtTable.ListRows
        ' 获取当前行的各项数据
        rangeID = currentRow.Range(dtTable.ListColumns("Range ID").Index).Value
        startDate = currentRow.Range(dtTable.ListColumns("Start Date").Index).Value
        totalDays = currentRow.Range(dtTable.ListColumns("Total Days").Index).Value
        statusDetail = currentRow.Range(dtTable.ListColumns("Status Detail").Index).Value
        
        ' 在Quarter Schedule中查找Range ID对应的行（A列）
        Set foundRow = qsSheet.Range("A:A").Find(what:=rangeID, LookIn:=xlValues, LookAt:=xlWhole)
        ' 在Quarter Schedule中查找Start Date对应的列（第6行）
        Set foundCol = qsSheet.Range("6:6").Find(what:=startDate, LookIn:=xlValues, LookAt:=xlWhole)
        
        ' 检查是否找到匹配的行和列
        If Not foundRow Is Nothing And Not foundCol Is Nothing Then
            Set targetCell = qsSheet.Cells(foundRow.Row, foundCol.Column)
            
            ' 根据Total Days动态合并单元格并设置样式
            With targetCell.Resize(, totalDays)
                .Merge Across:=True
                .Value = statusDetail
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = vbYellow
            End With
        Else
            ' 提示未找到匹配项
            MsgBox "未找到Range ID: " & rangeID & " 或 Start Date: " & startDate & " 的对应位置", vbExclamation
        End If
    Next currentRow
    
    Application.ScreenUpdating = True
    MsgBox "处理完成", vbInformation
End Sub

关键修改说明 #

• 遍历DataTable所有行：通过ListObject.ListRows集合实现循环，逐个处理表格中的每一行数据，替代原代码仅处理单行的逻辑
• 明确工作表引用：直接指定Data Table和Quarter Schedule工作表对象，避免依赖当前活动工作表导致的错误
• 动态合并范围：使用Resize(, totalDays)根据当前行的Total Days数值调整合并的列数，实现动态合并
• 严格匹配查找：在Find方法中添加LookAt:=xlWhole，确保完全匹配Range ID和Start Date，避免部分匹配导致的错误
• 错误提示优化：针对查找失败的情况，给出具体的未找到项信息，便于排查问题
• 性能保持：全程关闭屏幕更新，处理完成后恢复，提升运行效率

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