如何利用VBA实现数据的自动分列？

lbay

tyce168 发表于 2016-1-17 07:09
您的代码是图片，能传个附件吗？让表1只是原题目，第一行是标题，数据从第二行开始，一共3000行数据，想 ...

替你抄写了蓝老师的代码，附件如下：

豆芽ldy

lbay 发表于 2016-1-17 10:03

活雷锋啊，唉，好多代码看不懂0.0

wang-way

练手

ykcbf1100

文本拆分，练习一下。
原文还是需要规范一点，这样才能提高拆分准确率

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.17
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .Range("a3:c" & r)
   
5.     End With
   
6.     ReDim brr(1 To r, 1 To 9)
   
7.     For i = 2 To UBound(arr)
   
8.         m = m + 1
   
9.         brr(m, 1) = arr(i, 1)
   
10.         brr(m, 9) = arr(i, 3)
    
11.         st = Split(WorksheetFunction.Trim(arr(i, 2)), "）")
    
12.         bt = st(0) & "）"
    
13.         brr(m, 2) = bt
    
14.         s = Split(st(1))
    
15.         n = 2
    
16.         For x = 0 To UBound(s)
    
17.             n = n + 1
    
18.             brr(m, n) = s(x)
    
19.         Next
    
20.     Next
    
21.     With Sheets("结果")
    
22.         .UsedRange.Offset(1).Clear
    
23.         .[a2].Resize(m, 9) = brr
    
24.         .[a2].Resize(m, 9).Borders.LineStyle = 1
    
25.         .[a2].Resize(m, 9).EntireColumn.AutoFit
    
26.     End With
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

usedrange

参与一下

1. Sub t()
   
2.     Dim arr, brr, s, m%, til, n%, j%, i%
   
3.     m = [b4].End(4).Row
   
4.     ReDim arr(1 To m - 2, 1 To 9)
   
5.     til = Array("序号", "题目", "选项A", "选项B", "选项C", "选项D", "选项E", "选项F", "答案")
   
6.     brr = [b4].CurrentRegion
   
7.     n = 1
   
8.     With CreateObject("vbscript.regexp")
   
9.         .Global = True
   
10.         .MultiLine = True
    
11.         .Pattern = "\W+|[A-Z]?、\W+"
    
12.         For Each k In til
    
13.             arr(1, n) = k: n = n + 1
    
14.         Next k
    
15.         For j = 2 To UBound(brr)
    
16.             Set s = .Execute(brr(j, 2))
    
17.             If s.Count > 0 Then
    
18.                 For i = 0 To s.Count - 1
    
19.                     arr(j, i + 2) = s(i).Value
    
20.                 Next i
    
21.                 arr(j, 1) = j - 1
    
22.                 arr(j, 9) = brr(j, 3)
    
23.             End If
    
24.         Next j
    
25.         [a18].Resize(UBound(arr), UBound(arr, 2)) = arr
    
26.         Set s = Nothing
    
27.     End With
    
28. End Sub
    

复制代码