[已解决]求达到这样效果的VBA代码。

hua221

求达到这样效果的VBA代码。

最佳答案

月排行榜 / 总排行榜

xdragon

2014-3-24 01:15

1. Sub t()
   
2.   Dim arr(), re(), i&, j As Byte, n$
   
3.   arr = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
   
4.   ReDim re(1 To UBound(arr), 9)
   
5.   For i = 1 To UBound(arr)
   
6.     For j = 1 To Len(arr(i, 1))
   
7.       n = Mid(arr(i, 1), j, 1)
   
8.       re(i, n) = n
   
9.     Next
   
10.   Next
    
11.   Range("D2").Resize(UBound(arr), 10) = re
    
12. End Sub
    

复制代码

跳转到最佳答案楼层

hua221

如图

xdragon

1. Sub t()
   
2.   Dim arr(), re(), i&, j As Byte, n$
   
3.   arr = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
   
4.   ReDim re(1 To UBound(arr), 9)
   
5.   For i = 1 To UBound(arr)
   
6.     For j = 1 To Len(arr(i, 1))
   
7.       n = Mid(arr(i, 1), j, 1)
   
8.       re(i, n) = n
   
9.     Next
   
10.   Next
    
11.   Range("D2").Resize(UBound(arr), 10) = re
    
12. End Sub
    

复制代码

baksy

hua221 发表于 2014-3-24 00:13
如图

公式解决；
D2单元格复制公式
=IF(ISERROR(SEARCH(D$1,$B2,1)),"",D$1)
公式横拉、下拉。

hua221

xdragon 发表于 2014-3-24 01:15

正是我没想明白的。
感谢xdragon的无私帮助！！！赞赞赞赞赞赞赞赞赞赞赞赞赞赞赞赞！

hua221

baksy 发表于 2014-3-24 06:20
公式解决；
D2单元格复制公式
=IF(ISERROR(SEARCH(D$1,$B2,1)),"",D$1)

谢谢！！！！！两种方式都有了。