如何用Sheet2的ComboBox筛选Sheet1数据并修复VBA类型不匹配错误

问题背景 #

我有两个工作表：

1. Sheet1（主数据表）（空值为测试故意设置）：

2. Sheet2（人员所属团队表）：

需求 #

通过ComboBox选择Sheet2中的团队，将Sheet1中对应团队的人员数据筛选后显示在ListBox中，同时计算添加日期、修改日期与当前日期的间隔天数。

问题 #

编写的showList过程（在ComboBox Change事件中调用）运行时出现**Type mismatch（类型不匹配）**错误。

原代码 #

Sub showList()
    Dim ws As Worksheet, colList As Collection
    Dim arrData, arrList, i As Long, j As Long
    Dim targetTeam As Variant
    ' *** 
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim arr: arr = ws2.Range("B1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(arr)
        dict(arr(i, 2)) = Empty
    Next
   ' ***

    Set colList = New Collection
    Set ws = Worksheets("Sheet1")
    arrData = ws.Range("A1:E" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)
    For i = 2 To UBound(arrData)
            targetTeam = Application.VLookup((arrData(i, 2)), ws2.Range("B1").CurrentRegion.Value, -1, False)
                If dict.exists(arrData(i, 1)) And cmbTeam = targetTeam Then
                    colList.Add i, CStr(i)
                End If

    Next
    ReDim arrList(1 To colList.count + 1, 1 To UBound(arrData))
    For j = 1 To 5
        arrList(1, j) = arrData(1, j) ' header
        arrList(1, 4) = "Date Added Duration"
        arrList(1, 5) = "Date Modified Duration"
        For i = 1 To colList.count
                arrList(i + 1, j) = arrData(colList(i), j)
                    Dim dateA As Variant
                    Dim dateB As Variant
                    Dim dateC As Variant
                    Dim difference1 As Long
                    Dim difference2 As Long
                
                ' Assign values to the dates
                dateA = arrList(i + 1, 2)
                dateB = arrList(i + 1, 3)
                dateC = Format(Now, "m/d/yyyy")
                
                ' Calculate the difference in days
                difference1 = DateDiff("d", dateA, dateC) 'date today minus date added
                
                If Not dateA = "" Then
                    If difference1 > 1 Then
                    arrList(i + 1, 4) = difference1 & " days"
                    Else
                    arrList(i + 1, 4) = difference1 & " day"
                    End If
                Else
                    arrList(i + 1, 4) = "Missing"
                End If
                
                difference2 = DateDiff("d", dateB, dateC) 'date today minus date modified
                
                If Not dateB = "" Then
                    If difference2 > 1 Then
                    arrList(i + 1, 5) = difference2 & " days"
                    Else
                    arrList(i + 1, 5) = difference2 & " day"
                    End If
                Else
                    arrList(i + 1, 5) = "Missing"
                End If
        Next
    Next
    With Me.ListBox1
        .Clear
        .ColumnCount = UBound(arrData, 2)
        .list = arrList
    End With
End Sub

错误原因分析 #

1. VLookup参数无效：原代码中VLookup的列索引参数为-1，这是非法值（列索引必须为正整数），且查找逻辑颠倒（应该通过姓名找团队，而非添加日期）。
2. 日期类型混用：dateC被格式化为字符串，而dateA/dateB是日期型，DateDiff要求参数为日期型，导致类型不匹配。
3. 空值判断错误：数组中的空值是Empty而非空字符串，Not dateA = ""无法正确识别空单元格。
4. 循环逻辑混乱：内层循环嵌套错误，导致日期计算被重复执行，数组赋值逻辑冲突。

修复后的代码 #

Sub showList()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim arrData As Variant, arrTeam As Variant
    Dim dictTeam As Object
    Dim colList As Collection
    Dim arrList As Variant
    Dim i As Long, j As Long
    Dim targetName As String, currentTeam As String
    Dim dateA As Date, dateB As Date, dateToday As Date
    Dim diff1 As Long, diff2 As Long
    
    ' 初始化对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set dictTeam = CreateObject("Scripting.Dictionary")
    Set colList = New Collection
    
    ' 构建姓名-团队映射字典
    arrTeam = ws2.Range("A1").CurrentRegion.Value
    For i = 2 To UBound(arrTeam)
        targetName = Trim(arrTeam(i, 2))
        If targetName <> "" Then
            dictTeam(targetName) = arrTeam(i, 1)
        End If
    Next i
    
    ' 获取当前选中的团队
    currentTeam = Me.cmbTeam.Value
    ' 加载Sheet1主数据
    arrData = ws1.Range("A1:C" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 筛选对应团队的人员行
    For i = 2 To UBound(arrData)
        targetName = Trim(arrData(i, 1))
        If dictTeam.Exists(targetName) And dictTeam(targetName) = currentTeam Then
            colList.Add i
        End If
    Next i
    
    ' 初始化输出数组（含2个计算列）
    ReDim arrList(1 To colList.Count + 1, 1 To 5)
    ' 设置表头
    arrList(1, 1) = arrData(1, 1)
    arrList(1, 2) = arrData(1, 2)
    arrList(1, 3) = arrData(1, 3)
    arrList(1, 4) = "Date Added Duration"
    arrList(1, 5) = "Date Modified Duration"
    
    dateToday = Date ' 获取当前日期（日期型）
    
    ' 填充数据并计算间隔天数
    For i = 1 To colList.Count
        ' 复制原始数据列
        For j = 1 To 3
            arrList(i + 1, j) = arrData(colList(i), j)
        Next j
        
        ' 计算添加日期间隔
        If IsDate(arrData(colList(i), 2)) Then
            dateA = arrData(colList(i), 2)
            diff1 = DateDiff("d", dateA, dateToday)
            arrList(i + 1, 4) = diff1 & IIf(diff1 > 1, " days", " day")
        Else
            arrList(i + 1, 4) = "Missing"
        End If
        
        ' 计算修改日期间隔
        If IsDate(arrData(colList(i), 3)) Then
            dateB = arrData(colList(i), 3)
            diff2 = DateDiff("d", dateB, dateToday)
            arrList(i + 1, 5) = diff2 & IIf(diff2 > 1, " days", " day")
        Else
            arrList(i + 1, 5) = "Missing"
        End If
    Next i
    
    ' 更新ListBox
    With Me.ListBox1
        .Clear
        .ColumnCount = 5
        .List = arrList
    End With
    
    ' 释放资源
    Set dictTeam = Nothing
    Set colList = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

关键修复点说明 #

1. 替换VLookup为字典：用字典存储姓名-团队映射，避免VLookup的参数错误，同时提升查找效率。
2. 规范日期类型：使用Date函数获取当前日期（日期型），用IsDate判断单元格是否为有效日期，彻底解决类型不匹配问题。
3. 优化空值判断：通过Trim(targetName) <> ""和IsDate准确识别空值与无效数据。
4. 重构循环逻辑：将数据复制与日期计算分离，避免重复执行，提升代码可读性和运行效率。
5. 修正数组维度：明确输出数组为5列，与ListBox的ColumnCount匹配，避免数据错位。

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