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

tyce168

单位试题的题目和选项是在一起的，题很多，如何通过VBA按选项自动进行分列呢？选项数量是不固定的，希望在新工作表中实现？谢谢！

蓝桥玄霜

请见代码。
把表1第14行的标题复制到表2的第一行；
把C列后面的设置为自动换行格式。

autumnalRain

1. Sub test()
   
2.     For Each cell In Range(Cells(4, "b"), Cells(4, "b").End(xlDown))
   
3.         With CreateObject("VBSCRIPT.REGEXP")
   
4.             .Global = True
   
5.             .MultiLine = True
   
6.             .Pattern = "[A-F]、[\u4e00-\u9fa5]+\s?.[\u4e00-\u9fa5]+\s?.[\u4e00-\u9fa5]+"
   
7.             Set mats = .Execute(cell.Value)
   
8.              Cells(15, "b").Offset(m) = .Replace(cell.Value, "")
   
9.               k = 0
   
10.               For j = 0 To mats.Count - 1
    
11.                   Cells(15 + m, 3 + k) = mats(j)
    
12.                   k = k + 1
    
13.               Next j
    
14.               m = m + 1
    
15.         End With
    
16.     Next
    
17. End Sub

复制代码

autumnalRain

其他的你完善下如序号

fkeih_007

1. Sub Test() 'fkeih_007
   
2. Dim Rxg As Object, arr, brr, crr
   
3. Set Rxg = CreateObject("VBScript.RegExp")
   
4.     Rxg.Global = True: Rxg.Pattern = "([A-F]、)"
   
5. arr = Sheet1.Range("A3:C5")
   
6. ReDim brr(1 To UBound(arr), 1 To 9)
   
7. For i = 2 To UBound(arr)
   
8.      brr(i - 1, 1) = arr(i, 1)
   
9.        crr = Split(Rxg.Replace(arr(i, 2), "#"), "#")
   
10.          For j = 2 To UBound(crr) + 1
    
11.            brr(i - 1, j) = crr(j - 2)
    
12.          Next
    
13.         brr(i - 1, 9) = arr(i, 3)
    
14.      Erase crr
    
15. Next
    
16. Sheet2.Activate
    
17. [A2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
18. [A2].Resize(UBound(brr), UBound(brr, 2)).WrapText = True
    
19. End Sub
    

复制代码

tyce168

fkeih_007 发表于 2016-1-16 11:09

好像没有在新表实现，能跟个附件吗？

tyce168

autumnalRain 发表于 2016-1-16 10:41
其他的你完善下如序号

谢谢答复，一楼附件已更新。您的附件运行不太完美，假如表1的B列都是题目，第一行是标题，数据从第二行开始的，A列是序号，C列是答案，您怎么实现需要转换的数据是在新表中实现呢？而不是在原表。

tyce168

蓝桥玄霜 发表于 2016-1-16 10:15
请见代码。
把表1第14行的标题复制到表2的第一行；
把C列后面的设置为自动换行格式。

您的代码是图片，能传个附件吗？让表1只是原题目，第一行是标题，数据从第二行开始，一共3000行数据，想实现转换的效果，均出现在新表（表2）中。

蓝桥玄霜

抄一遍如此少量的代码应该不是问题吧。
想要不断进步，动手吧。

lbay

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

1. Sub lqxs()
   
2. Dim arr, i&, brr, zm, aa, j&, m&, n&
   
3. Sheet2.Activate
   
4. [a2:h500].ClearContents
   
5. [a2:h500].Borders.LineStyle = xlNone
   
6. zm = Array("A", "B", "C", "D", "E", "F")
   
7. arr = Sheet1.[a3].CurrentRegion
   
8. ReDim brr(1 To UBound(arr) - 1, 1 To 8)
   
9. For i = 2 To UBound(arr)
   
10.     brr(i - 1, 1) = arr(i, 1)
    
11.        If InStr(arr(i, 2), "）") Then
    
12.           aa = Split(arr(i, 2), "）")
    
13.           brr(i - 1, 2) = aa(o) & ")": n = Len(aa(1))
    
14.            For j = UBound(zm) To 0 Step -1
    
15.                m = InStr(aa(1), zm(j))
    
16.                If m <> 0 Then
    
17.                   brr(i - 1, j + 3) = zm(j) & "、" & Mid(aa(1), m + 2, n - m - 3): n = m
    
18.                End If
    
19.            Next
    
20.        End If
    
21. Next
    
22. [A2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. [A2].Resize(UBound(brr), UBound(brr, 2)).Borders.LineStyle = 1
    
24. End Sub
    
25. 蓝老师说的对，初学者就得多练习抄写代码，从中也能认真的学习很多东西。可能你是没时间，帮你抄写了。

复制代码