选择题题目选项合并在单元格问题

ly8421

问题：把工作簿里面的 问题.zip (35.75 KB, 下载次数: 10)

2024-6-20 15:52 上传

点击文件名下载附件

，答案在另外一个单元格。其中题目选项不确定，可能有1-6个.谢谢！

ykcbf1100

前面部分应该简单，但大题有些麻烦，没看懂什么情况。

wang-way

不规范   谁有办法

usedrange

1. Sub t()
   
2.     Dim arr, brr, i%, m%, r%
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     m = UBound(arr): r = 1
   
5.     ReDim brr(1 To m, 1 To 3)
   
6.     For i = 1 To m
   
7.         If InStr(arr(i, 1), "大题") Then Exit For
   
8.         If InStr(arr(i, 1), "(") Or InStr(arr(i, 1), "（") Then
   
9.             brr(r, 1) = arr(i, 1)
   
10.         ElseIf InStr(arr(i, 1), "答案") Then
    
11.             brr(r, 3) = Mid(arr(i, 1), 5): r = r + 1
    
12.         Else
    
13.             brr(r, 2) = brr(r, 2) + arr(i, 1)
    
14.         End If
    
15.     Next i
    
16.     Sheet2.[a5].Resize(UBound(brr), 3) = brr
    
17. End Sub

复制代码

ly8421

ykcbf1100 发表于 2024-6-20 16:24
前面部分应该简单，但大题有些麻烦，没看懂什么情况。

大题不管他

ly8421

usedrange 发表于 2024-6-20 16:54

谢谢，非常完美！如果要把大题题目放在A列，答案放在C列怎么办？求帮忙

gwjkkkkk

ly8421 发表于 2024-6-20 17:51
大题不管他

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, r&
   
    ar = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    ReDim br(1 To UBound(ar), 1 To 3)
    br(1, 1) = "题目": br(1, 2) = "选项": br(1, 3) = "答案"
    r = 1
   
    With CreateObject("VBScript.RegExp")
        For i = 1 To UBound(ar)
            If InStr(ar(i, 1), "大题") Then Exit For
            .Pattern = "\d+、"
            If .test(ar(i, 1)) Then
                r = r + 1
                br(r, 1) = ar(i, 1)
            Else
                .Pattern = "[A-F]\."
                If .test(ar(i, 1)) Then
                    br(r, 2) = br(r, 2) & ar(i, 1)
                Else
                    If InStr(ar(i, 1), "【答案】") Then br(r, 3) = Trim(Replace(ar(i, 1), "【答案】", ""))
                End If
            End If
            
        Next i
    End With
    With Worksheets(2)
        .Cells.Clear
        .[a1].Resize(r, 3) = br
        .Activate
    End With
    Beep
End Sub

gwjkkkkk

ly8421 发表于 2024-6-20 17:51
大题不管他

参与一下。。。

ly8421

gwjkkkkk 发表于 2024-6-20 18:25
参与一下。。。

感觉还得麻烦一下，大题部分还是整一下，题目放在A列，答案放在C列，谢谢

usedrange

ly8421 发表于 2024-6-20 17:58
谢谢，非常完美！如果要把大题题目放在A列，答案放在C列怎么办？求帮忙

1. Sub t2()
   
2.     Dim arr, brr, i%, m%, r%, j%
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     m = UBound(arr): r = 1
   
5.     ReDim brr(1 To m, 1 To 3)
   
6.     For i = 1 To m
   
7.         If InStr(arr(i, 1), "大题") Then Exit For
   
8.         If InStr(arr(i, 1), "(") Or InStr(arr(i, 1), "（") Then
   
9.             brr(r, 1) = arr(i, 1)
   
10.         ElseIf InStr(arr(i, 1), "答案") Then
    
11.             brr(r, 3) = Mid(arr(i, 1), 5): r = r + 1
    
12.         Else
    
13.             brr(r, 2) = brr(r, 2) + arr(i, 1)
    
14.         End If
    
15.     Next i
    
16.     For j = i+1 To m
    
17.         brr(r, 1) = brr(r, 1) + arr(j, 1)
    
18.         If InStr(arr(j, 1), "答案") Then
    
19.             brr(r, 3) = Mid(arr(j, 1), 5)
    
20.             r = r + 1
    
21.         End If
    
22.     Next j
    
23.     Sheet2.[a5].Resize(UBound(brr), 3) = brr
    
24. End Sub
    

复制代码