把选择题的ABCD选项用vba 变成与题目同一行的不同列中

cyq4896

需求：请老师们把选择题的ABCD选项用vba 变成与题目同一行的不同列中，如sheets("效果")中，只模拟了一题。

饮冰e士

公式不是更方便么

ykcbf1100

感觉用正则更简单一点，但我用正则不成功。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim reg As New RegExp
   
5.     With reg
   
6.         .Global = True
   
7.         .Pattern = "(\d+|[A-Z])[.．].*?(?=[A-Z][.．]|$)"
   
8.         Set mh = .Execute(Range("a26").Value)
   
9.     End With
   
10.     With Worksheets("填空")
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         arr = .Range("a1:a" & r)
    
13.     End With
    
14.     ReDim brr(1 To UBound(arr), 1 To 20)
    
15.     m = 0
    
16.     For i = 1 To UBound(arr)
    
17.         Set mh = reg.Execute(arr(i, 1))
    
18.         For j = 0 To mh.Count - 1
    
19.             xh = mh(j).SubMatches(0)
    
20.             If xh Like "#*" Then
    
21.                 m = m + 1
    
22.                 brr(m, 1) = mh(j)
    
23.             Else
    
24.                 n = Asc(xh) - 63
    
25.                 brr(m, n) = mh(j)
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     With Worksheets("效果")
    
30.         .Range("a1").Resize(m, UBound(brr, 2)) = brr
    
31.     End With
    
32. End Sub
    

复制代码

ykcbf1100

数据不规范，所以，在转换以前还得先清洗数据。

1. Sub ykcbf()   '//2024.12.13
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("填空")
   
5.         r = .UsedRange.Find("*", , -4163, , 1, 2).Row
   
6.         arr = .[a1].Resize(r, 1)
   
7.     End With
   
8.     a = [{"A．","B．","C．","D．","E．"}]
   
9.     b = [{2,3,4,5,6}]
   
10.     For x = 1 To UBound(a)
    
11.         d(a(x)) = b(x)
    
12.     Next
    
13.     ReDim brr(1 To r, 1 To 6)
    
14.     For i = 1 To UBound(arr)
    
15.         If Val(arr(i, 1)) Then k = k + 1: d1(k) = i
    
16.     Next
    
17.     On Error Resume Next
    
18.     For k = 1 To d1.Count
    
19.         r1 = d1(k)
    
20.         n = 1
    
21.         If k = d1.Count Then r2 = r Else r2 = d1(k + 1) - 1
    
22.         l = r2 - r1 + 1
    
23.         stt = Replace(Replace(arr(r1, 1), ".", "．"), "、", "．")
    
24.         Z = InStr(stt, a(1))
    
25.         m = m + 1
    
26.         If Z Then
    
27.             brr(m, 1) = Left(stt, Z - 1)
    
28.             st = Split(WorksheetFunction.Trim(Mid(stt, Z)))
    
29.             For Each ma In st
    
30.                 For x = 1 To UBound(a)
    
31.                     If InStr(ma, a(x)) Then
    
32.                         brr(m, d(a(x))) = ma
    
33.                         Exit For
    
34.                     End If
    
35.                 Next
    
36.             Next
    
37.         Else
    
38.             brr(m, 1) = arr(r1, 1)
    
39.         End If
    
40.         For i = r1 + 1 To r2
    
41.             stt = Replace(Replace(arr(i, 1), ".", "．"), "、", "．")
    
42.             st = Split(WorksheetFunction.Trim(stt))
    
43.             For Each ma In st
    
44.                 For x = 1 To UBound(a)
    
45.                     If InStr(ma, a(x)) Then
    
46.                         brr(m, d(a(x))) = ma
    
47.                         Exit For
    
48.                     End If
    
49.                 Next
    
50.             Next
    
51.         Next
    
52.     Next
    
53.     With Sheets("效果")
    
54.         .UsedRange.ClearContents
    
55.         .[a1].Resize(m, 6) = brr
    
56.     End With
    
57.     MsgBox "OK！"
    
58. End Sub
    
59. 
    

复制代码

chxw68

参与一下。

cyq4896

chxw68 发表于 2024-12-13 15:10
参与一下。

谢谢褚老师。

cyq4896

ykcbf1100 发表于 2024-12-13 15:08
感觉用正则更简单一点，但我用正则不成功。

谢谢了，老师辛苦了。