[已解决]数值范围内展开

hadesqu

想请问下，我想把A列的数展开成C列这样，可以用VBA 实现吗？怎么写呢？

最佳答案

月排行榜 / 总排行榜

hello_cgj

2015-6-11 19:50

1. Sub 示例()
   
2.     Dim arr, brr(1 To 10000, 1 To 1), k, i, sr, n
   
3.     arr = Range("a1").CurrentRegion
   
4.     For k = 1 To UBound(arr)
   
5.         sr = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
   
6.         For i = VBA.Split(sr, ":")(0) To VBA.Split(sr, ":")(1) Step -1
   
7.             n = n + 1
   
8.             brr(n, 1) = i
   
9.         Next
   
10.     Next
    
11.     Range("d1").Resize(n, 1).ClearContents
    
12.     Range("d1").Resize(n, 1) = brr
    
13. End Sub
    

复制代码

跳转到最佳答案楼层

hello_cgj

1. Sub 示例()
   
2.     Dim arr, brr(1 To 10000, 1 To 1), k, i, sr, n
   
3.     arr = Range("a1").CurrentRegion
   
4.     For k = 1 To UBound(arr)
   
5.         sr = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
   
6.         For i = VBA.Split(sr, ":")(0) To VBA.Split(sr, ":")(1) Step -1
   
7.             n = n + 1
   
8.             brr(n, 1) = i
   
9.         Next
   
10.     Next
    
11.     Range("d1").Resize(n, 1).ClearContents
    
12.     Range("d1").Resize(n, 1) = brr
    
13. End Sub
    

复制代码

hadesqu

hello_cgj 发表于 2015-6-11 19:50

谢谢你帮忙写的VBA ，但是我还有个问题，就是没有数值没有范围，只是单个数，这个VBA 好像还是会报错，你能再帮忙看看嘛? 附件A列是我都要展开的数，你能帮忙再改改吗？

广陵王

谢谢分享！学习了！

hello_cgj

试了下，你测试下。

1. 
   
2. Sub 示例()
   
3.     Dim arr, brr(1 To 10000, 1 To 1), k, i, sr, n
   
4.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
   
5.     For k = 1 To UBound(arr)
   
6.     If arr(k, 1) <> "" Then
   
7.          If InStr(arr(k, 1), ":") = 0 Then
   
8.          n = n + 1
   
9.           brr(n, 1) = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
   
10.           Else
    
11.         sr = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
    
12.         For i = VBA.Split(sr, ":")(0) To VBA.Split(sr, ":")(1) Step -1
    
13.             n = n + 1
    
14.             brr(n, 1) = i
    
15.         Next
    
16.         End If
    
17.         End If
    
18.     Next
    
19.     Range("d1").Resize(n, 1).ClearContents
    
20.     Range("d1").Resize(n, 1) = brr
    
21. End Sub
    

复制代码

hadesqu

hello_cgj 发表于 2015-6-15 11:08
试了下，你测试下。

完美！太厉害了，就是还有一点，我A列的范围是以空行来区分的，你看不能在展开完一组后，也空一行给我来区分下呢？最好能和A 列对齐，谢谢~

hello_cgj

肯定对不齐啊。呵呵
是展开的嘛
只有能对齐的对齐咯

1. 
   
2. Sub 示例()
   
3.     Dim arr, brr(1 To 10000, 1 To 1), k, i, sr, n
   
4.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
   
5.     For k = 1 To UBound(arr)
   
6.     If arr(k, 1) = "" Then
   
7.     n = n + 1
   
8.     brr(n, 1) = ""
   
9. 
   
10.          ElseIf InStr(arr(k, 1), ":") = 0 Then
    
11.          n = n + 1
    
12.           brr(n, 1) = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
    
13.           Else
    
14.         sr = Mid(Mid(arr(k, 1), 2, 10), 1, Len(Mid(arr(k, 1), 2, 10)) - 1)
    
15.         For i = VBA.Split(sr, ":")(0) To VBA.Split(sr, ":")(1) Step -1
    
16.             n = n + 1
    
17.             brr(n, 1) = i
    
18.         Next
    
19.         End If
    
20.         
    
21.     Next
    
22.     Range("d1").Resize(n, 1).ClearContents
    
23.     Range("d1").Resize(n, 1) = brr
    
24. End Sub
    
25. 
    

复制代码

hadesqu

hello_cgj 发表于 2015-6-15 15:01
肯定对不齐啊。呵呵
是展开的嘛
只有能对齐的对齐咯

太好了， 这样就可以了，谢谢你了~