如果单元格值以特定字母开头，则复制并粘贴

Question

在A列中，有包含问题、选项和其他数据的数据。每行中的选项均以 A B C D 开头。我只需复制选项和问题并粘贴到下一栏 B 中。样本数据如下所示。

我尝试了下面的代码，但它仅复制选项，而不复制选项 A 上方的问题。我需要帮助来修复代码。而且这段代码运行缓慢。

ColA                                     ColB

Program Math
Exercise 3-24
This is a sample test
Select the correct answer
1 Question                               1 Question
A choice-1                               A choice-1
B choice-2                               B choice-2
C choice-3                               C choice-3
D choice-4                               D choice-4
Program Math
Exercise 5-12
This is a sample test
Select the correct answer
2 Question                               2 Question
A choice-1                               A choice-1
B choice-2                               B choice-2
C choice-3                               C choice-3
D choice-4                               D choice-4
Program Math
Exercise 2-14
This is a sample test
Select the correct answer
1 Question
A choice-1
B choice-2
C choice-3
D choice-4

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

Answer 1

您可以将标准合并到一个循环中，并包括对问题的检查。这也将加快执行速度。

Sub CopyPasteChoices()

Dim a As Range

Sheet2.Activate

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


End Sub