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

画像のようなデータを以下のように処理するVBAを書きたいです。
データの特徴
・ランダムにクイズを出すプログラムで得られたデータが2列ずつ蓄積されていきます。
・左側の列の1行目には日付が入り、右側の列の1行目には、その回の正答率が入ります。
・2行目以降の左側の列には、問題番号が入ります。
・2行目以降の右側の列には、解答が正答 (1) だったか誤答 (2) だったかが入ります。
・クイズはランダム提示されるため、同じ問題が複数回実行される可能性があります。

このデータに以下のような処理を行いたいです。
・日付を正答率の上のセルに挿入する(正答率と、問題番号・正誤の範囲を一行分下げる)
・問題番号と正誤の並び替え(昇順)
・問題番号が重複しているものは、削除して1つにする(例:14行目と17行目など)
 →この時に残すものは上に入っているもので良い
・歯抜けになっている問題番号と空白セルを挿入する
 (開始の問題番号はかならず1とする、終了は最大値でOK)
・左の列(問題番号が入力されている列)を削除して、左に寄せる。
以上です。説明が分かりにくい点もあると思いますが、よろしくお願いいたします。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2018/06/18 20:52:09
  • 終了:2018/06/19 23:24:17
id:cpsaku

起点となるセル(例えば、G1)の指定は、カーソルでアクティブセルを選択する形で良いです。

ベストアンサー

id:Z1000S No.1

Z1000S回答回数31ベストアンサー獲得回数212018/06/19 11:01:31

ポイント200pt

・問題番号が重複しているものは、削除して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
id:cpsaku

完璧に求めていた処理でした。
本当にありがとうございましたm(_ _)m

2018/06/19 23:24:01

その他の回答(0件)

id:Z1000S No.1

Z1000S回答回数31ベストアンサー獲得回数212018/06/19 11:01:31ここでベストアンサー

ポイント200pt

・問題番号が重複しているものは、削除して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
id:cpsaku

完璧に求めていた処理でした。
本当にありがとうございましたm(_ _)m

2018/06/19 23:24:01

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません