跪求高手！批量转换格式的问题。

chenyiyu3

附件里的“初级工”是原始格式，题目很多，我只留了几题做例子。“需转化成的格式”是在“初级工”的原始表格上做完操作的目标格式。
1、把空行删除。
2、把“展开解析和说明”改行删除。
3、题干和序号合成一行。
4、“，每题1分”去掉。
5、正确答案的答案移到相对应的第二列并去掉每个答案间的符号。
6、各选项移动到和题干一个单元格，并换行。
7、判断题需要“正确”和“错误”前加上“A、”和“B、”，答案的“正确”和“错误”需转换成A和B。
8、单选题和多选题的选项数量不定，最少可能A和B两个选项，最多达到A、B、C、D、E、F、G、H共8各选项。
跪求可以通过VBA一键转换的方法，谢谢！！！
如果各位高手没有时间弄这么多，能否只帮弄一下  “3、题干和序号合成一行。6、各选项移动到和题干一个单元格，并换行”这两项要求？

grf1973

1. Sub 转换()
   
2.     arr = Range("a1:a" & [a65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 2)
   
4.     brr(1, 2) = "正确答案"
   
5.     ss = "一二三四五六七八九十"
   
6.     For i = 1 To UBound(arr)
   
7.         x = Replace(Replace(arr(i, 1), "（", "("), "）", ")")
   
8.         If x Like "*题(*" Then     '题大类
   
9.             s1 = s1 + 1
   
10.             s2 = 0
    
11.             n = n + 1
    
12.             x = Split(x, "每")(0)
    
13.             x = Mid(ss, s1, 1) & "、" & Left(x, Len(x) - 1) & ")"
    
14.             brr(n, 1) = x
    
15.         ElseIf InStr(x, "()") Or InStr(x, "( )") Then   '题干
    
16.             n = n + 1
    
17.             s2 = s2 + 1
    
18.             brr(n, 1) = s2 & "、" & x
    
19.             For k = i + 1 To UBound(arr)
    
20.                 y = arr(k, 1)
    
21.                 If Not y Like "正确答案*" Then
    
22.                     If y = "正确" Then y = "A.正确"
    
23.                     If y = "错误" Then y = "B.错误"
    
24.                     brr(n, 1) = brr(n, 1) & Chr(10) & y
    
25.                 Else
    
26.                     brr(n, 2) = Replace(Mid(y, 6), ",", "")
    
27.                     If brr(n, 2) = "正确" Then brr(n, 2) = "A"
    
28.                     If brr(n, 2) = "错误" Then brr(n, 2) = "B"
    
29.                     Exit For
    
30.                 End If
    
31.             Next
    
32.         End If
    
33.     Next
    
34.     Sheets(3).[a1].Resize(n, 2) = brr
    
35. End Sub
    

复制代码

chenyiyu3

谢谢高手出手相救！我测试了我整个题库，发现从某道多选题起，答案错位，该题我已标黄色，麻烦大神再帮我看一下，感激不尽！

grf1973

判断题干是通过是否含"()"来实现的。多选第40题没有括号，所以没有判断出来。

grf1973

换个思路找题干。

1. Sub 转换1()
   
2.     arr = Range("a1:a" & [a65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 2)
   
4.     brr(1, 2) = "正确答案"
   
5.     ss = "一二三四五六七八九十"
   
6.     For i = 1 To UBound(arr)
   
7.         x = Trim(arr(i, 1))
   
8.         If x Like "*题(*" Then     '题大类
   
9.             s1 = s1 + 1
   
10.             s2 = 0
    
11.             n = n + 1
    
12.             x = Split(x, "每")(0)
    
13.             x = Mid(ss, s1, 1) & "、" & Left(x, Len(x) - 1) & ")"
    
14.             brr(n, 1) = x
    
15.         ElseIf x = "正确" Or x Like "A*" Then '第一个答案
    
16.             xx = arr(i - 1, 1)
    
17.             n = n + 1
    
18.             s2 = s2 + 1
    
19.             brr(n, 1) = s2 & "、" & xx
    
20.             For k = i To UBound(arr)
    
21.                 y = arr(k, 1)
    
22.                 If Not y Like "正确答案*" Then
    
23.                     If y = "正确" Then y = "A.正确"
    
24.                     If y = "错误" Then y = "B.错误"
    
25.                     brr(n, 1) = brr(n, 1) & Chr(10) & y
    
26.                 Else
    
27.                     brr(n, 2) = Replace(Mid(y, 6), ",", "")
    
28.                     If brr(n, 2) = "正确" Then brr(n, 2) = "A"
    
29.                     If brr(n, 2) = "错误" Then brr(n, 2) = "B"
    
30.                     i = k
    
31.                     Exit For
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next
    
36.     Sheets(3).[a1].Resize(n, 2) = brr
    
37. End Sub

复制代码