Excel VBA代码修复与优化：复制题目及A-D选项至Column B

需求：A列包含题目、以A/B/C/D开头的选项及其他数据，需要将题目和对应选项复制到相邻的B列。现有代码仅能复制选项，无法复制选项A上方的题目，且运行速度较慢，需修复并优化。

示例数据 #

原有代码 #

Sub CopyPasteChoices()

Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range

Sheet2.Activate

For Each a In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If a.Value Like "A *" Then
        a.Copy Destination:=a.Offset(0, 2)
    End If
Next a

For Each b In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If b.Value Like "B *" Then
        b.Copy Destination:=b.Offset(0, 2)
    End If
Next b

For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If c.Value Like "C *" Then
        c.Copy Destination:=c.Offset(0, 2)
    End If
Next c

For Each d In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If d.Value Like "D *" Then
        d.Copy Destination:=d.Offset(0, 2)
    End If
Next d

End Sub

修复并优化后的代码 #

Sub CopyQuestionsAndChoices()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim isInQuestionBlock As Boolean
    
    ' 禁用屏幕刷新和事件，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 直接指定目标工作表，避免Activate操作
    Set ws = ThisWorkbook.Sheets("Sheet2")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 单次遍历处理所有行
    For i = 1 To lastRow
        ' 识别题目行（匹配"* Question"格式）
        If ws.Cells(i, 1).Value Like "* Question" Then
            isInQuestionBlock = True
            ' 复制题目到B列
            ws.Cells(i, 2).Value = ws.Cells(i, 1).Value
        ' 识别选项行（A/B/C/D开头）且处于题目块内
        ElseIf isInQuestionBlock And ws.Cells(i, 1).Value Like "[A-D] *" Then
            ' 复制选项到B列
            ws.Cells(i, 2).Value = ws.Cells(i, 1).Value
        ' 遇到非题目非选项行，结束当前题目块
        ElseIf isInQuestionBlock Then
            isInQuestionBlock = False
        End If
    Next i
    
    ' 恢复屏幕刷新和事件
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "复制完成", vbInformation
End Sub

关键优化与修复点 #

• 修复题目复制问题：通过识别* Question格式的题目行，标记当前处于题目块内，同步复制题目到B列，并持续复制后续的A/B/C/D选项，直到遇到无关行结束当前块。
• 大幅提升运行速度：
  • 把原有4次重复遍历改为单次遍历，减少循环次数。
  • 禁用屏幕刷新和事件触发，避免界面交互开销。
  • 用直接赋值.Value替代Copy方法，跳过剪贴板操作。
  • 直接指定工作表对象，移除Activate这类低效的界面操作。
• 逻辑更严谨：通过isInQuestionBlock状态变量精准控制复制范围，避免误复制无关数据。

内容的提问来源于stack exchange，提问作者Siraj Syed