【Excel VBA】四択クイズのプログラムで次の問題に進めない

Module2

1Option Explicit 2 3Private Const DATA_BEGIN_ROW As Long = 2 4 5Public Sub sortAndSerialize() 6 7 Dim ws As Worksheet 8 Dim lCol As Long 9 Dim sDate As String 10 Dim sCorrectAnswerRate As String 11 12 Set ws = ThisWorkbook.ActiveSheet 13 14 With ws 15 lCol = ActiveCell.Column 16 17 sDate = .Cells(1, lCol).Value 18 19 Do Until sDate = "" 20 If Not IsDate(sDate) Then 21 Exit Do 22 End If 23 24 sCorrectAnswerRate = .Cells(1, lCol + 1).Value 25 26 If sCorrectAnswerRate <> "" And (Not IsDate(sCorrectAnswerRate)) Then 27 '並べ替え 28 Call sortDatas(ws, lCol) 29 30 '欠番挿入、重複番号削除 31 Call toSerialize(ws, lCol) 32 33 '日付移動、問題番号列削除 34 Call deleteQNoCol(ws, lCol) 35 End If 36 37 lCol = lCol + 1 38 39 sDate = .Cells(1, lCol).Value 40 Loop 41 End With 42End Sub 43 44Private Sub sortDatas(ByRef ws As Worksheet, ByVal lQNoCol As Long) 45 46 Dim lEndRow As Long 47 48 With ws 49 lEndRow = .Cells(.Rows.Count, lQNoCol).End(xlUp).Row 50 51 With .Sort.SortFields 52 .Clear 53 .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol), ws.Cells(lEndRow, lQNoCol)), _ 54 SortOn:=xlSortOnValues, _ 55 Order:=xlAscending, _ 56 DataOption:=xlSortNormal 57 58 '複数の異なる回答時：1を残す場合 59' .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol + 1), ws.Cells(lEndRow, lQNoCol + 1)), _ 60 SortOn:=xlSortOnValues, _ 61 Order:=xlAscending, _ 62 DataOption:=xlSortNormal 63 '複数の異なる回答時：0を残す場合 64 .Add Key:=ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol + 1), ws.Cells(lEndRow, lQNoCol + 1)), _ 65 SortOn:=xlSortOnValues, _ 66 Order:=xlDescending, _ 67 DataOption:=xlSortNormal 68 End With 69 70 With .Sort 71 .SetRange ws.Range(ws.Cells(DATA_BEGIN_ROW, lQNoCol), ws.Cells(lEndRow, lQNoCol + 1)) 72 .Header = xlNo 73 .MatchCase = False 74 .Orientation = xlTopToBottom 75 .Apply 76 End With 77 End With 78End Sub 79 80Private Sub toSerialize(ByRef ws As Worksheet, ByVal lCol As Long) 81 82 Dim lCurrentRow As Long 83 Dim sCurrentQNo As String 84 Dim lCurrentQNo As Long 85 Dim lPrevQNo As Long 86 Dim lInsertRows As Long 87 88 lCurrentRow = DATA_BEGIN_ROW 89 90 lPrevQNo = 0 91 92 With ws 93 sCurrentQNo = CStr(.Cells(lCurrentRow, lCol).Value) 94 95 Do Until sCurrentQNo = "" 96 lCurrentQNo = CLng(sCurrentQNo) 97 98 If lCurrentQNo > lPrevQNo + 1 Then 99 '欠番あり 100 lInsertRows = lCurrentQNo - lPrevQNo - 1 101 102 .Range(.Cells(lCurrentRow, lCol), .Cells(lCurrentRow + lInsertRows - 1, lCol + 1)).Insert Shift:=xlDown 103 104 .Cells(lCurrentRow + lInsertRows, lCol).AutoFill Destination:=.Range(.Cells(lCurrentRow, lCol), .Cells(lCurrentRow + lInsertRows, lCol)), Type:=xlFillSeries 105 106 With .Range(.Cells(lCurrentRow, lCol + 1), .Cells(lCurrentRow + lInsertRows - 1, lCol + 1)) 107 .NumberFormatLocal = "G/標準" 108 End With 109 110 lCurrentRow = lCurrentRow + lInsertRows + 1 111 ElseIf lPrevQNo = lCurrentQNo Then 112 '同番 113 .Range(.Cells(lCurrentRow - 1, lCol), .Cells(lCurrentRow - 1, lCol + 1)).Delete Shift:=xlUp 114 Else 115 lCurrentRow = lCurrentRow + 1 116 End If 117 118 sCurrentQNo = CStr(.Cells(lCurrentRow, lCol).Value) 119 120 lPrevQNo = .Cells(lCurrentRow - 1, lCol).Value 121 Loop 122 End With 123End Sub 124 125Private Sub deleteQNoCol(ByRef ws As Worksheet, ByVal lDateCol As Long) 126 127 With ws 128 .Cells(1, lDateCol + 1).Insert Shift:=xlDown 129 130 .Cells(1, lDateCol).Copy Destination:=.Cells(1, lDateCol + 1) 131 132 .Columns(lDateCol).Delete 133 End With 134End Sub