画像のようなデータを以下のように処理するVBAを書きたいです。
データの特徴
・ランダムにクイズを出すプログラムで得られたデータが2列ずつ蓄積されていきます。
・左側の列の1行目には日付が入り、右側の列の1行目には、その回の正答率が入ります。
・2行目以降の左側の列には、問題番号が入ります。
・2行目以降の右側の列には、解答が正答 (1) だったか誤答 (2) だったかが入ります。
・クイズはランダム提示されるため、同じ問題が複数回実行される可能性があります。
このデータに以下のような処理を行いたいです。
・日付を正答率の上のセルに挿入する(正答率と、問題番号・正誤の範囲を一行分下げる)
・問題番号と正誤の並び替え(昇順)
・問題番号が重複しているものは、削除して1つにする(例:14行目と17行目など)
→この時に残すものは上に入っているもので良い
・歯抜けになっている問題番号と空白セルを挿入する
(開始の問題番号はかならず1とする、終了は最大値でOK)
・左の列(問題番号が入力されている列)を削除して、左に寄せる。
以上です。説明が分かりにくい点もあると思いますが、よろしくお願いいたします。
・問題番号が重複しているものは、削除して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
・問題番号が重複しているものは、削除して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
完璧に求めていた処理でした。
本当にありがとうございましたm(_ _)m
完璧に求めていた処理でした。
2018/06/19 23:24:01本当にありがとうございましたm(_ _)m