[已解决]求助

水木

再求助：拆分.rar (10.16 KB, 下载次数: 7)

2017-4-20 15:17 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

Excel学徒123

2017-4-20 16:03

1. Option Explicit
   
2. 
   
3. Sub SplitInfo()
   
4.     Dim arrSrc, arrRst()
   
5.     Dim lrow&, lCnt&, lCount&
   
6.     Dim icol%, iLocal%
   
7.     Dim strText$
   
8.     arrSrc = Range("a2:a" & Cells(Rows.Count, 1).End(3).Row).Value
   
9.     For lrow = 1 To UBound(arrSrc) Step 4
   
10.         For lCnt = lrow To lrow + 3
    
11.             strText = strText & arrSrc(lCnt, 1)
    
12.         Next
    
13.         For icol = 1 To Len(strText) / 4
    
14.             For iLocal = icol To Len(strText) Step 3
    
15.                 lCount = lCount + 1
    
16.                 ReDim Preserve arrRst(1 To lCount)
    
17.                 arrRst(lCount) = Mid(strText, iLocal, 1)
    
18.             Next
    
19.         Next
    
20.         strText = ""
    
21.     Next
    
22.     Range("d2").Resize(lCount) = Application.Transpose(arrRst)
    
23. End Sub
    

复制代码

跳转到最佳答案楼层

大灰狼1976

附件请测试。

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, j&, k&
   
3. arr = [a1].CurrentRegion
   
4. ReDim brr(1 To (UBound(arr) - 1) * 3, 1 To 1)
   
5. For i = 2 To UBound(arr) Step 4
   
6.   For j = 1 To 3
   
7.     For k = i To i + 3
   
8.       r = r + 1
   
9.       brr(r, 1) = Mid(arr(k, 1), j, 1)
   
10.     Next k
    
11.   Next j
    
12. Next i
    
13. [i2].Resize(r) = brr
    
14. End Sub

复制代码

大灰狼1976

结果在I列，附件。

水木

老师：您好！运行不了，提示“越界”。是不是数据量大的问题。A列有上千行数据，代码怎么改？

Excel学徒123

1. Option Explicit
   
2. 
   
3. Sub SplitInfo()
   
4.     Dim arrSrc, arrRst()
   
5.     Dim lrow&, lCnt&, lCount&
   
6.     Dim icol%, iLocal%
   
7.     Dim strText$
   
8.     arrSrc = Range("a2:a" & Cells(Rows.Count, 1).End(3).Row).Value
   
9.     For lrow = 1 To UBound(arrSrc) Step 4
   
10.         For lCnt = lrow To lrow + 3
    
11.             strText = strText & arrSrc(lCnt, 1)
    
12.         Next
    
13.         For icol = 1 To Len(strText) / 4
    
14.             For iLocal = icol To Len(strText) Step 3
    
15.                 lCount = lCount + 1
    
16.                 ReDim Preserve arrRst(1 To lCount)
    
17.                 arrRst(lCount) = Mid(strText, iLocal, 1)
    
18.             Next
    
19.         Next
    
20.         strText = ""
    
21.     Next
    
22.     Range("d2").Resize(lCount) = Application.Transpose(arrRst)
    
23. End Sub
    

复制代码

Excel学徒123

水木 发表于 2017-4-20 16:03
老师：您好！运行不了，提示“越界”。是不是数据量大的问题。A列有上千行数据，代码怎么改？

直接在楼层下面点回复，这样别人才知道你回复了，再试试5楼的代码

大灰狼1976

几千行数据不能算多吧，你出错的附件呢，不看附件不好判断。