VBA遍历任务排班表生成Outlook约会时遇类型不匹配错误

错误直接原因 #

代码中If Row = 1 Then触发类型不匹配，是因为Row是Range对象，直接拿它和数值1对比属于对象与基础数据类型的非法操作，必须改用Row.Value获取单元格实际内容后再做判断。

其他需要修正的问题 #

除上述直接错误，代码还有多处潜在问题：

1. 变量未初始化：tech1Int、tech2Int、techDInt、apntDay未赋值初始值，默认是Empty，参与运算会导致逻辑错误。
2. 字符串未加引号：If Row = D Then中的D会被识别为变量，而非字符串值，需改为"D"。
3. 对象赋值错误：tbl = ActiveSheet.ListObjects(1)未使用Set关键字，ListObject是对象类型，必须用Set完成赋值。
4. 行索引逻辑混乱：原代码中techRow的递增逻辑错误，无法正确获取技术人员姓名。
5. 数组未重置：每处理完一列后，数组索引未重置，会导致下一列数据继续追加到数组末尾，引发越界或数据混乱。

修正后的完整代码 #

Sub CreateAppointments_Click()
    Dim tech1() As String
    Dim techD() As String
    Dim tech2() As String
    Dim tech1Int As Integer, tech2Int As Integer, techDInt As Integer
    Dim apntDay As Integer
    Dim tbl As ListObject
    Dim rng As Range
    Dim col As Range
    Dim cell As Range
    Dim techName As String
    
    Application.ScreenUpdating = False
    
    ' 初始化变量
    tech1Int = 0
    tech2Int = 0
    techDInt = 0
    apntDay = 0
    
    ' 正确引用表格对象
    Set tbl = ActiveSheet.ListObjects(1)
    Set rng = tbl.DataBodyRange ' 仅遍历表格的数据区域，跳过表头
    
    ' 遍历每一列（日期列）
    For Each col In rng.Columns
        apntDay = apntDay + 1
        ' 重置数组索引与大小
        tech1Int = 0
        tech2Int = 0
        techDInt = 0
        ReDim tech1(0 To 0)
        ReDim techD(0 To 0)
        ReDim tech2(0 To 0)
        
        ' 遍历当前列的所有单元格（技术人员行）
        For Each cell In col.Cells
            ' 获取当前技术人员姓名（假设表格第1列为姓名列，可根据实际调整索引）
            techName = tbl.ListColumns(1).DataBodyRange(cell.Row - tbl.HeaderRowRange.Row).Value
            
            Select Case cell.Value
                Case 1
                    ' 动态扩容数组并添加姓名
                    If tech1Int > 0 Then ReDim Preserve tech1(0 To tech1Int)
                    tech1(tech1Int) = techName
                    tech1Int = tech1Int + 1
                Case 2
                    If tech2Int > 0 Then ReDim Preserve tech2(0 To tech2Int)
                    tech2(tech2Int) = techName
                    tech2Int = tech2Int + 1
                Case "D"
                    If techDInt > 0 Then ReDim Preserve techD(0 To techDInt)
                    techD(techDInt) = techName
                    techDInt = techDInt + 1
            End Select
        Next cell
        
        ' 仅当有任务分配时调用约会创建函数
        If tech1Int > 0 Or tech2Int > 0 Or techDInt > 0 Then
            Call createOutlookAppointment(tech1, tech2, techD, apntDay)
        End If
    Next col
  
    Application.ScreenUpdating = True
End Sub

代码说明 #

• 使用DataBodyRange限定遍历范围，避免表头干扰；
• 用Select Case替代多分支If，逻辑更清晰；
• 采用动态数组ReDim Preserve，适配不同数量的技术人员；
• 修正姓名获取逻辑，确保正确匹配对应技术人员；
• 增加空数组判断，避免无效调用；
• 每列处理前重置数组，保证数据独立性。

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