データ処理をするVBAについて

・問題番号が重複しているものは、削除して1つにする(例：14行目と17行目など)
　→この時に残すものは上に入っているもので良い

ひとつの問題に対し、正しい回答と間違った回答がある場合
どちらを残したいのでしょう？
どちらでも出来るよう、ソースにコメント入れてあるので、
切り替えて試してみて下さい。

        lCol = ActiveCell.Column

の部分を

        lCol = 1

としても、１列目からヘッダ部分を見て、処理済みの列（「１行目が日付で、右隣の１行目が日付でない」で判定）をスキップして、右へ右へと探しに行くので、こちらも使えるようなら使ってみて下さい。

Option Explicit


Private Const DATA_BEGIN_ROW     As Long = 2


Public Sub sortAndSerialize()

    Dim ws          As Worksheet
    Dim lCol        As Long
    Dim sDate       As String
    Dim sCorrectAnswerRate  As String

    Set ws = ThisWorkbook.ActiveSheet

    With ws
        lCol = ActiveCell.Column

        sDate = .Cells(1, lCol).Value

        Do Until sDate = ""
            If Not IsDate(sDate) Then
                Exit Do
            End If

            sCorrectAnswerRate = .Cells(1, lCol + 1).Value

            If sCorrectAnswerRate <> "" And (Not IsDate(sCorrectAnswerRate)) Then
                '並べ替え
                Call sortDatas(ws, lCol)

                '欠番挿入、重複番号削除
                Call toSerialize(ws, lCol)

                '日付移動、問題番号列削除
                Call deleteQNoCol(ws, lCol)
            End If

            lCol = lCol + 1

            sDate = .Cells(1, lCol).Value
        Loop
    End With

End Sub

Private Sub sortDatas(ByRef ws As Worksheet, ByVal lQNoCol As Long)

    Dim lEndRow     As Long

    With ws
        lEndRow = .Cells(.Rows.Count, lQNoCol).End(xlUp).Row

        With .Sort.SortFields
            .Clear
            .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol), ws.Cells(lEndRow, lQNoCol)), _
                 SortOn:=xlSortOnValues, _
                 Order:=xlAscending, _
                 DataOption:=xlSortNormal

            '複数の異なる回答時：1を残す場合
            .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol + 1), ws.Cells(lEndRow, lQNoCol + 1)), _
                 SortOn:=xlSortOnValues, _
                 Order:=xlAscending, _
                 DataOption:=xlSortNormal
            '複数の異なる回答時：0を残す場合
'            .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol + 1), ws.Cells(lEndRow, lQNoCol + 1)), _
                 SortOn:=xlSortOnValues, _
                 Order:=xlDescending, _
                 DataOption:=xlSortNormal
        End With

        With .Sort
            .SetRange ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol), ws.Cells(lEndRow, lQNoCol + 1))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With
    End With

End Sub

Private Sub toSerialize(ByRef ws As Worksheet, ByVal lCol As Long)

    Dim lCurrentRow As Long
    Dim sCurrentQNo As String
    Dim lCurrentQNo As Long
    Dim lPrevQNo    As Long
    Dim lInsertRows As Long

    lCurrentRow = DATA_BEGIN_ROW

    lPrevQNo = 0

    With ws
        sCurrentQNo = CStr(.Cells(lCurrentRow, lCol).Value)

        Do Until sCurrentQNo = ""
            lCurrentQNo = CLng(sCurrentQNo)

            If lCurrentQNo > lPrevQNo + 1 Then
                '欠番あり
                lInsertRows = lCurrentQNo - lPrevQNo - 1

                .Range(.Cells(lCurrentRow, lCol), .Cells(lCurrentRow + lInsertRows - 1, lCol + 1)).Insert Shift:=xlDown

                .Cells(lCurrentRow + lInsertRows, lCol).AutoFill Destination:=.Range(.Cells(lCurrentRow, lCol), .Cells(lCurrentRow + lInsertRows, lCol)), Type:=xlFillSeries

                With .Range(.Cells(lCurrentRow, lCol + 1), .Cells(lCurrentRow + lInsertRows - 1, lCol + 1))
                    .NumberFormatLocal = "G/標準"
                End With

                lCurrentRow = lCurrentRow + lInsertRows + 1
            ElseIf lPrevQNo = lCurrentQNo Then
                '同番
                .Range(.Cells(lCurrentRow - 1, lCol), .Cells(lCurrentRow - 1, lCol + 1)).Delete Shift:=xlUp
            Else
                lCurrentRow = lCurrentRow + 1
            End If

            sCurrentQNo = CStr(.Cells(lCurrentRow, lCol).Value)

            lPrevQNo = .Cells(lCurrentRow - 1, lCol).Value
        Loop
    End With

End Sub

Private Sub deleteQNoCol(ByRef ws As Worksheet, ByVal lDateCol As Long)

    With ws
        .Cells(1, lDateCol + 1).Insert Shift:=xlDown

        .Cells(1, lDateCol).Copy Destination:=.Cells(1, lDateCol + 1)

        .Columns(lDateCol).Delete
    End With

End Sub