起点となるｾﾙ(例えば､G1)の指定は､ｶｰｿﾙでｱｸﾃｨﾌﾞｾﾙを選択する形で良いです｡

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

ひとつの問題に対し､正しい回答と間違った回答がある場合
どちらを残したいのでしょう？
どちらでも出来るよう､ｿｰｽにｺﾒﾝﾄ入れてあるので､
切り替えて試してみて下さい｡

 lCol = ActiveCell.Column

の部分を

 lCol = 1

としても､1列目からﾍｯﾀﾞ部分を見て､処理済みの列(｢1行目が日付で､右隣の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