VBA Filter函数仅返回首个匹配项问题求助

问题描述 #

我在单元格区域C3:G3中存有数据，使用Filter函数进行筛选（监视窗口显示筛选逻辑有效），但粘贴结果时仅输出筛选范围内的首个匹配项。我尝试添加Transpose转置操作，但两种方式均得到相同的单一输出，相关代码如下：

Sub filter_test()
Dim PhoneAry As Variant
Dim myAry(0 To 4) As String


myAry(0) = Range("C3").Value
myAry(1) = Range("D3").Value
myAry(2) = Range("E3").Value
myAry(3) = Range("F3").Value
myAry(4) = Range("G3").Value

PhoneAry = filter(myAry, "Wireless")
    
Dim Destination As Range
Set Destination = Range("C4:G4")
Set Destination = Destination.Resize(UBound(PhoneAry), 1)

Destination.Value = Application.transpose(PhoneAry)
End sub

效果说明：C4:G4区域仅填充了第一个符合筛选条件的值，其余单元格为空。

问题原因 #

1. 目标区域方向错误：先将目标区域设为横向的C4:G4，随后用Resize(UBound(PhoneAry), 1)把它改成了纵向单列区域，再对数组转置，导致数组方向与目标区域不匹配，最终只填充第一个值。
2. 转置操作冗余且错误：Filter函数返回的是一维横向数组，直接赋值给横向单元格区域即可，转置会把数组转为纵向，反而无法正确填充到横向区域。

修正后的代码 #

Sub filter_test()
    Dim PhoneAry As Variant
    Dim myAry As Variant
    
    ' 直接将单元格区域转为数组，简化赋值步骤
    myAry = Application.Transpose(Range("C3:G3").Value)
    
    PhoneAry = Filter(myAry, "Wireless")
    
    Dim Destination As Range
    Set Destination = Range("C4")
    
    ' 仅当筛选结果非空时执行赋值
    If UBound(PhoneAry) >= 0 Then
        ' 调整目标区域为1行，列数等于筛选结果的数量
        Set Destination = Destination.Resize(1, UBound(PhoneAry) + 1)
        ' 一维数组直接赋值给横向区域，无需转置
        Destination.Value = PhoneAry
    End If
End Sub

关键修正点 #

• 直接读取单元格区域为数组，避免手动逐个赋值的繁琐操作
• 根据筛选结果的数量调整目标区域的列数，确保所有匹配项都能填充
• 去掉多余的转置操作，一维数组直接匹配横向单元格区域的赋值逻辑
• 增加非空判断，防止筛选结果为空时出现运行错误

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