[已解决]VBA数组读取单元格数据求助

公爵

如图所示，怎么样将左侧的数据转换成效果图那样的格式，求助各位大侠，感激不尽！

最佳答案

月排行榜 / 总排行榜

hello_cgj

2015-6-18 19:48

来一个

1. Sub 示例()
   
2.     Dim k, i, j, n, arr, brr(1 To 1000000, 1 To 8)
   
3.     arr = Range("a1").CurrentRegion
   
4.     For k = 1 To 8
   
5.         brr(1, k) = arr(1, k)
   
6.     Next
   
7.     n = 1
   
8.     For k = 2 To UBound(arr)
   
9.         For j = 1 To UBound(Split(arr(k, 4), "、")) + 1
   
10.             n = n + 1
    
11.             brr(n, 1) = arr(k, 1)
    
12.             brr(n, 2) = arr(k, 2)
    
13.             brr(n, 3) = arr(k, 3)
    
14.             brr(n, 4) = Split(arr(k, 4), "、")(j - 1)
    
15.             brr(n, 5) = arr(k, 5)
    
16.             brr(n, 6) = arr(k, 6)
    
17.             brr(n, 7) = arr(k, 7)
    
18.             brr(n, 8) = arr(k, 8)
    
19.         Next
    
20.     Next
    
21.     Range("u1").Resize(n, 8) = brr
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

hello_cgj

来一个

1. Sub 示例()
   
2.     Dim k, i, j, n, arr, brr(1 To 1000000, 1 To 8)
   
3.     arr = Range("a1").CurrentRegion
   
4.     For k = 1 To 8
   
5.         brr(1, k) = arr(1, k)
   
6.     Next
   
7.     n = 1
   
8.     For k = 2 To UBound(arr)
   
9.         For j = 1 To UBound(Split(arr(k, 4), "、")) + 1
   
10.             n = n + 1
    
11.             brr(n, 1) = arr(k, 1)
    
12.             brr(n, 2) = arr(k, 2)
    
13.             brr(n, 3) = arr(k, 3)
    
14.             brr(n, 4) = Split(arr(k, 4), "、")(j - 1)
    
15.             brr(n, 5) = arr(k, 5)
    
16.             brr(n, 6) = arr(k, 6)
    
17.             brr(n, 7) = arr(k, 7)
    
18.             brr(n, 8) = arr(k, 8)
    
19.         Next
    
20.     Next
    
21.     Range("u1").Resize(n, 8) = brr
    
22. End Sub
    

复制代码

lmze2000

1. Sub Cf()
   
2.     Dim Arr, Brr, Crr, Js%
   
3.     ReDim Crr(1 To 200, 1 To 8)
   
4.     On Error Resume Next
   
5.     Arr = Sheet1.Range("a1").CurrentRegion
   
6.     For i = 2 To UBound(Arr)
   
7.         Brr = Split(Arr(i, 4), "、")
   
8.         For j = 0 To UBound(Brr)
   
9.             Js = Js + 1
   
10.             Crr(Js, 1) = Arr(i, 1)
    
11.             Crr(Js, 2) = Arr(i, 2)
    
12.             Crr(Js, 3) = Arr(i, 3)
    
13.             Crr(Js, 4) = Brr(j)
    
14.             Crr(Js, 5) = Arr(i, 5)
    
15.             Crr(Js, 6) = Arr(i, 6)
    
16.             Crr(Js, 7) = Arr(i, 7)
    
17.             Crr(Js, 8) = Arr(i, 8)
    
18.         Next
    
19.     Next
    
20.     [l2].Resize(Js, 8) = Crr
    
21.     MsgBox "处理完成", , "提示"
    
22. End Sub

复制代码

看一下是不是这样的效果

公爵

lmze2000 发表于 2015-6-18 19:56
看一下是不是这样的效果

非常感谢你，代码完全能够满足我的需要，但最佳只能评一个，只好给先回答的，不好意思哈

lmze2000

客气，能解决问题就好。