对单元格分列并添加行数复制数据（详见附表）

一点轻烟

要求对某一列进行分列

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a2").Resize(r - 1, c)
   
8.     ReDim brr(1 To UBound(arr) * 10, 1 To UBound(arr, 2))
   
9.     For i = 1 To UBound(arr)
   
10.       crr = Split(arr(i, 16), ",")
    
11.       For k = 0 To UBound(crr)
    
12.         m = m + 1
    
13.         For j = 1 To UBound(arr, 2)
    
14.           brr(m, j) = arr(i, j)
    
15.         Next
    
16.         brr(m, 16) = crr(k)
    
17.       Next
    
18.     Next
    
19.   End With
    
20.   With Worksheets("sheet2")
    
21.     .UsedRange.Offset(1, 0).ClearContents
    
22.     .Range("a:a,h:h").NumberFormatLocal = "@"
    
23.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
24.   End With
    
25. End Sub
    

复制代码

chxw68

详见附件。

一点轻烟

chxw68 发表于 2018-9-3 16:28
详见附件。

谢谢 很厉害啊