[已解决]求助老师或热心网友帮忙修改下查找符合条件的vba

357111

目前这个代码只能找到%100符合的 如果  有一条不符合就报错  请老师 '热心网友帮忙修改下

1. 
   

复制代码

最佳答案

月排行榜 / 总排行榜

橘子红

2016-4-11 20:19

测试了没问题

跳转到最佳答案楼层

橘子红

dim 后面加一句试试
on error resume next

357111

橘子红 发表于 2016-4-11 19:57
dim 后面加一句试试
on error resume next

加了 不行  提示类型不匹配    可以下载附件帮看看 吗 谢谢

橘子红

Sub aa()
    Dim d As New Dictionary
    Dim arr, arr1, arr2
    Dim i As Long
    On Error Resume Next
    Set d = CreateObject("scripting.dictionary")
    arr1 = Range("F2:F" & [F65536].End(xlUp).Row)
    ReDim arr2(1 To UBound(arr1), 1 To 2)
    With Sheets("2")
        arr = .Range("A2:C" & .[A65536].End(xlUp).Row)
    End With
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
    Next i
    For i = 1 To UBound(arr1)
        arr2(i, 1) = d(arr1(i, 1))(0)
        arr2(i, 2) = d(arr1(i, 1))(1)
    Next i
    Range("i2").Resize(UBound(arr2), 2) = arr2
End Sub

橘子红

测试了没问题

357111

橘子红 发表于 2016-4-11 20:19
测试了没问题

嗯 就这样   

爱疯

建议不要设置帖的权限，因为可能导致混乱的模仿。