VBA多行拆分为一行多列

feilanga

如图所示，希望拆分为图2结果 题目一列 答案ABCDEF列  最后一列把A列括号里面的答案列出   注意一点：答案个数不同 有ABCD  有ABCDE  自己弄了半天就卡在输出结果错乱上面 因为答案个数不同 ，求前辈代写一下把 谢谢

feilanga

求审核通过，谢谢

3190496160

每一题的备选答案都是5项，每一题的正确答案都是在括号内，数据非常规范的呀，

3190496160

Sub 整理数据()
Dim ar As Variant
With Sheets("多项选择题")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & r)
End With
Dim rr()
ReDim rr(1 To UBound(ar))
For i = 1 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        zf = Split(Trim(ar(i, 1)), ".")(0)
        If IsNumeric(zf) Then
            n = n + 1
            rr(n) = i
        End If
    End If
Next i
Dim br()
On Error Resume Next
ReDim br(1 To UBound(ar), 1 To 50)
For i = 1 To n
    y = 1
    m = m + 1
    ks = rr(i)
    js = rr(i + 1)
    da = ar(ks, 1)
    br(m, 1) = ar(ks, 1)
    For s = ks + 1 To js - 1
        If Trim(ar(s, 1)) <> "" Then
            y = y + 1
            br(m, y) = ar(s, 1)
        End If
    Next s
    xh1 = InStr(da, "（") + 1
    xh2 = InStr(da, "）") - 1
    y = y + 1
    br(m, y) = Mid(da, xh1, xh2 - xh1 + 1)
Next i
With Sheets("结果")
    .[a1].CurrentRegion = ""
    .[a1].Resize(m, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub

3190496160

工作簿2.rar (73.08 KB, 下载次数: 26)

2021-2-15 12:22 上传

点击文件名下载附件

3190496160

数据非常不规范：
1，题号后面的点号有英文状态，有中文状态，甚至还有顿号
2、正确答案的括号，有半角的，有全角的，
所以，代码仅供参考

jjmysjg

留个记号，实用

准提部林

挺麻煩的:
Sub TEST_A1()
Dim Arr, Brr(1 To 20000, 1 To 7), i&, j%, N&, C%, V%, T$, T1$, T2$, TT$
Sheets("结果").UsedRange.ClearContents
Arr = Range(Sheets(1).[A1], Sheets(1).[A65536].End(xlUp))
For i = 1 To UBound(Arr)
    T = Trim(Replace(Arr(i, 1), " ", ""))
    If T = "" Then GoTo 101
    T1 = StrConv(T, vbNarrow)
    If Left(T1, 1) Like "[A-Z]" Then C = C + 1: Brr(N, C) = T: GoTo 101
    '-----------------------------------
    N = N + 1: C = 1: V = 0: TT = ""
    For j = 1 To Len(T1)
        T2 = Mid(T1, j, 3)
        If T2 Like "([A-Z])" Or T2 Like "([A-Z][A-Z]" Then V = 1
        If InStr("_(√)(×)", T2) Then V = 1
        If V = 1 Then
           TT = TT & Mid(T, j, 1)
           If Mid(T1, j, 1) = ")" Then Exit For
        End If
    Next j
    Brr(N, 1) = Replace(T, TT, "（" & String(9, " ") & "）")
    If TT <> "" Then Brr(N, 7) = Mid(Left(TT, Len(TT) - 1), 2)
101: Next i
Sheets("结果").[A1].Resize(N, 7).Value = Brr
End Sub

安永飞

好，做个标志，以后学习