In Column A
, there is data which contain question, choices and other data. The choices starts with A B C D in each row. I just need to copy the CHOICES and QUESTION and paste into next Column B
. Sample data as shown below.
I tried the below code, but it copies only the choices no the question whihc is above choice A. I need help to fix the code. Also this code runs slowly.
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
You can combine the criterias into one loop with including the check for the Question. This will also speed up the execution.
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 *" Then a.Offset(-1).Copy Destination:=a.Offset(-1, 2)
If a.Value Like "A *" Or a.Value Like "B *" Or a.Value Like "C *" Or a.Value Like "D *" Then
a.Copy Destination:=a.Offset(0, 2)
End If
Next a
End Sub