[已解决]查询并选定A列包含某字符，然后将查到的结果剪切到新的一列

丨Nevermore丨

图里面有详细说明。因为数据较多，不想用函数，用VBA可以解决吗。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-9-22 12:56

1. Sub Macro1()
   
2. Dim arr, brr, crr, i&, j&, s&
   
3. arr = Range("a1").CurrentRegion
   
4. brr = Range("c1").CurrentRegion
   
5. ReDim crr(1 To UBound(brr), 1 To 1)
   
6. For i = 2 To UBound(arr)
   
7.     s = 1: crr(s, 1) = arr(i, 1)
   
8.     For j = 2 To UBound(brr)
   
9.         If InStr(brr(j, 1), arr(i, 1)) Then s = s + 1: crr(s, 1) = brr(j, 1): brr(j, 1) = ""
   
10.     Next
    
11.     If s > 1 Then Cells(1, i + 4).Resize(s) = crr
    
12. Next
    
13. [c1].CurrentRegion = brr
    
14. [c1].Resize(UBound(brr)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    
15. End Sub

复制代码

跳转到最佳答案楼层

我是龙五

这问题好，就一句话，没看懂

qdae

挺难的

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, i&, j&, s&
   
3. arr = Range("a1").CurrentRegion
   
4. brr = Range("c1").CurrentRegion
   
5. ReDim crr(1 To UBound(brr), 1 To 1)
   
6. For i = 2 To UBound(arr)
   
7.     s = 1: crr(s, 1) = arr(i, 1)
   
8.     For j = 2 To UBound(brr)
   
9.         If InStr(brr(j, 1), arr(i, 1)) Then s = s + 1: crr(s, 1) = brr(j, 1): brr(j, 1) = ""
   
10.     Next
    
11.     If s > 1 Then Cells(1, i + 4).Resize(s) = crr
    
12. Next
    
13. [c1].CurrentRegion = brr
    
14. [c1].Resize(UBound(brr)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    
15. End Sub

复制代码

dsmch

………………

Excel学徒123

{:112:}