VBA实现多验证值与数据范围匹配并复制数据的问题求助

问题场景 #

我有工作表Sheet1，需要将其中指定三列数据复制到Sheet2。Sheet2的单元格J5设置了基于Sheet1的B列（从首行到最后一行）的多选项数据验证，用户选择多个值时，单元格内容会拼接成类似one, two, three的逗号分隔字符串。

需求是：将J5中选中的多个值与Sheet1的B列匹配，把对应行的指定列数据复制到Sheet2。但现有代码仅在J5为单个值时有效，多选时无法正常工作。

原代码 #

Sub test()

Dim WB1 As Workbook
Dim LastRow As Long

Dim I As Long


Set WB1 = ThisWorkbook


WB1.Sheets("Sheet2").Range("B6:H100" & LastRow).Clear

LastRow = WB1.Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).row




For I = 6 To LastRow
    If WB1.Sheets("Sheet1").Range("B" & I).Value = WB1.Sheets("Sheet2").Range("J5").Value Then
        WB1.Sheets("Sheet2").Range("D" & I, "F" & I).Value = WB1.Sheets("Sheet1").Range("D" & I, "F" & I).Value
        WB1.Sheets("Sheet2").Range("B" & I).Value = WB1.Sheets("Sheet1").Range("J5").Value
    End If
Next

End Sub

修改后的代码 #

Sub CopyMultiSelectedData()
    Dim WB1 As Workbook
    Dim lastRowSheet1 As Long
    Dim destRow As Long
    Dim selectedValues As Variant
    Dim i As Long
    Dim currentValue As String
    
    Set WB1 = ThisWorkbook
    
    ' 初始化目标起始行
    destRow = 6
    
    ' 清除Sheet2中之前的数据（从B6开始到最后一行的相关列）
    With WB1.Sheets("Sheet2")
        .Range("B" & destRow & ":H" & .Cells(Rows.Count, "B").End(xlUp).Row).Clear
    End With
    
    ' 获取Sheet1的B列最后一行行号
    lastRowSheet1 = WB1.Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    
    ' 将J5的逗号分隔值拆分成数组（注意分隔符是", "，包含空格）
    selectedValues = Split(WB1.Sheets("Sheet2").Range("J5").Value, ", ")
    
    ' 遍历Sheet1的B列数据（假设数据从第2行开始，可根据实际调整）
    For i = 2 To lastRowSheet1
        currentValue = WB1.Sheets("Sheet1").Range("B" & i).Value
        
        ' 检查当前值是否在选中的数组中
        If IsInArray(currentValue, selectedValues) Then
            ' 复制Sheet1的D-F列数据到Sheet2的对应位置
            WB1.Sheets("Sheet2").Range("D" & destRow & ":F" & destRow).Value = _
                WB1.Sheets("Sheet1").Range("D" & i & ":F" & i).Value
            ' 在Sheet2的B列写入匹配的值
            WB1.Sheets("Sheet2").Range("B" & destRow).Value = currentValue
            ' 目标行下移一行
            destRow = destRow + 1
        End If
    Next i
End Sub

' 自定义函数：检查值是否在数组中
Function IsInArray(searchVal As String, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If element = searchVal Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

关键改动说明 #

1. 拆分多选值为数组：用Split函数将J5中逗号分隔的字符串拆分成数组，分隔符使用", "（匹配多选后的拼接格式）。
2. 新增数组检查函数：自定义IsInArray函数，用于判断Sheet1当前行的B列值是否在选中的数组中，支持多选场景的匹配。
3. 调整目标行逻辑：用destRow变量跟踪Sheet2的写入位置，避免原代码中直接使用Sheet1行号导致的空行问题，每匹配一行就向下移动目标行。
4. 修正数据清除范围：原代码中Range("B6:H100" & LastRow)的写法错误，改为根据Sheet2的实际数据行清除，避免无效范围。
5. 遍历范围修正：原代码从第6行开始遍历Sheet1，改为从数据起始行（示例为第2行，可按需调整）开始，避免遗漏数据。

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