チェックシート回答自動転記

Option Explicit

Sub AnswertoQ(scorepnt As Variant, cmmtpnt As Variant, anspnt As Variant, PS1 As Boolean)
Dim anscnt As Long, memo As String

'PS1 = True ' PS1があればtrueになります。
    
    ' 英語回答の場合は転記列が異なる為変数で指定 和は2、英は3
    
    Dim rng As Range, Qrng As Range, Qtotal As Long, Qpnt As Long, topnt As Long
    Dim flag As Boolean, PS1i As Long, TargetWs As Worksheet, frws as Worksheet
     flag = False ' PS1がTrueになっているときP6例外処理時の分岐変数
     PS1i = 0 ' P6のPS1回答用変数
    Set frws = Thisworkbook.Activesheet
    Set Qrng = frws.Range(frws.Cells(2, "C"), frws.Cells(frws.Rows.Count, "C").End(xlUp))

    Qtotal = Qrng.Rows.Count

    On Error Resume Next ' エラーを無視して続行
    Set rng = Application.InputBox("ﾁｪｯｸｼｰﾄのセル範囲を選択してください:", "範囲選択", Type:=8)
    On Error GoTo 0 ' エラーハンドリングを再開
    If rng Is Nothing Then Exit Sub
    Set TargetWs = rng.Worksheet
    
    If rng.Cells(1, 1).Address = "$A$1" Then
        topnt = 1
    End If


If PS1 = True Then ' P6にてPS1がある場合の処理

    For Qpnt = 1 To Qtotal
        For topnt = topnt To rng.Rows.Count
            ' 転記ｼｰﾄのP番号と回答ｼｰﾄのP番号一致の場合転記
            If rng(topnt, 1).Value Like "*" & Qrng(Qpnt, 1) & "*" Then
                If flag = False Then
                    'スコアがないチェックシートの場合
                      If scorepnt <> 0 And scorepnt <> " " And scorepnt <> "" Then
                         rng(topnt, 1).Offset(, scorepnt) = Qrng(Qpnt, 1).Offset(, 1)
                      End If
                    
                    'コメントがないチェックシートの場合
                    If cmmtpnt <> 0 And cmmtpnt <> " " And cmmtpnt <> "" Then
                     rng(topnt, 1).Offset(, cmmtpnt) = Qrng(Qpnt, 1).Offset(, anspnt)
                    End If
                    
                    topnt = topnt + 1
                       If topnt > rng.Rows.Count Then
                           MsgBox "処理完了" & vbCr & "記載なかった項番:" & memo
                           Exit Sub
                        End If
                    anscnt = 0
                ' P6処理開始になる場合flagで指定(転記ファイルの場所から判断)
                        If Qrng(Qpnt, 1).Value Like "5.7" Then  'Qrng(Qpnt, 1) Like "*5.7*" Then
                            flag = True
                        End If
                    Exit For
                                            
                 ElseIf flag = True Then ' P6からP7.1手前まで処理(転記ファイルの場所から判断)
                        Do Until TargetWs.Cells(rng(topnt, 1).Row + PS1i, 1) Like "PS1"
                            PS1i = PS1i + 1
                        Loop

                        If scorepnt <> 0 And scorepnt <> " " And scorepnt <> "" Then
                            TargetWs.Cells(rng(topnt, 1).Row + PS1i, 1).Offset(, scorepnt) = Qrng(Qpnt, 1).Offset(, 1)
                        End If
                        
                        'コメントがないチェックシートの場合
                        If cmmtpnt <> 0 And cmmtpnt <> " " And cmmtpnt <> "" Then
                            TargetWs.Cells(rng(topnt, 1).Row + PS1i, 1).Offset(, cmmtpnt) = Qrng(Qpnt, 1).Offset(, anspnt)
                        End If
                        
                        PS1i = 0
                        ' P6処理終了の判断の為、転記ｼｰﾄのQpnt一つ下がP7かを判断
                        If Qrng(Qpnt + 1, 1) Like "*7.1*" Then
                            flag = False
                        End If
                        topnt = topnt + 1
                        
                        If topnt > rng.Rows.Count Then
                          MsgBox "処理完了" & vbCr & "記載なかった項番:" & memo
                          Exit Sub
                        End If
                
                        anscnt = 0
                        Exit For
                 End If
              Else
              'ﾁｪｯｸｼｰﾄで一部Pが抜けている場合6countで無し判断しQpnt増加、topnt戻す
              anscnt = anscnt + 1
                  If anscnt >= 6 Then
                    memo = memo & "/" & Qrng(Qpnt, 1)
                    Qpnt = Qpnt + 1
                    topnt = topnt - anscnt
                    anscnt = 0
                  End If
              End If
        Next topnt  '
        If topnt > rng.Rows.Count Then Exit For
    Next Qpnt
    
ElseIf PS1 = False Then 'PS1がP6にない場合通常処理

    For Qpnt = 1 To Qtotal
        For topnt = topnt To rng.Rows.Count
      '’’’’'ここで一度検索時に次に進まずに検索してる為重複転記に
            ' 転記ｼｰﾄのP番号と回答ｼｰﾄのP番号一致の場合転記
            If rng(topnt, 1).Value Like "*" & Qrng(Qpnt, 1) & "*" Then
                If flag = False Then
                    'スコアがないチェックシートの場合
                    If scorepnt <> 0 And scorepnt <> " " And scorepnt <> "" Then
                        rng(topnt, 1).Offset(, scorepnt) = Qrng(Qpnt, 1).Offset(, 1)
                    End If
                    'コメントがないチェックシートの場合
                    If cmmtpnt <> 0 And cmmtpnt <> " " And cmmtpnt <> "" Then
                        rng(topnt, 1).Offset(, cmmtpnt) = Qrng(Qpnt, 1).Offset(, anspnt)
                    End If
                    topnt = topnt + 1
                    If topnt > rng.Rows.Count Then
                        MsgBox "処理完了" & vbCr & "記載なかった項番:" & memo
                        Exit Sub
                    End If
                    anscnt = 0
                    Exit For
                 End If
             End If
                'ﾁｪｯｸｼｰﾄで一部Pが抜けている場合6countで無し判断しQpnt増加、topnt戻す
                 anscnt = anscnt + 1
                 If anscnt >= 6 Then
                    memo = memo & "/" & Qrng(Qpnt, 1)
                    Qpnt = Qpnt + 1
                    topnt = topnt - anscnt
                    anscnt = 0
                 End If
        Next topnt
        If topnt > rng.Rows.Count Then Exit For
    Next Qpnt
   MsgBox "処理完了" & vbCr & "記載がなかった項番:" & memo
End If

MsgBox "処理完了" & vbCr & "記載がなかった項番:" & memo

Unload AnswerUF
 
End Sub

Private Sub CommandButton1_Click()
Dim scorepnt As Long, cmmtpnt As Long, anspnt As Variant, PS1 As Boolean
    
    If scorepntBox.Value = "" And cmmtpntBox.Value = "" Then
        MsgBox "点数かコメントどちらかの位置は入力してください", vbExclamation, "入力エラー"
        Exit Sub
    End If
      ' 空欄なら処理を続行（値がない場合はスキップ）
    If scorepntBox.Value <> "" And Not IsNumeric(scorepntBox.Value) Then
        MsgBox "数値か空欄のままにしてください", vbExclamation, "入力エラー"
        Exit Sub
    End If

    If cmmtpntBox.Value <> "" And Not IsNumeric(cmmtpntBox.Value) Then
        MsgBox "数値か空欄のままにしてください", vbExclamation, "入力エラー"
        Exit Sub
    End If

    On Error Resume Next ' 空欄の場合対応
    scorepnt = LCase(scorepntBox.Value)
    cmmtpnt = LCase(cmmtpntBox.Value)
    On Error GoTo 0
    
'英語の場合の回答列代入
    If anspntBox Then
        anspnt = 3
    Else
        anspnt = 2
    End If
'PS1がある場合True
    If PS1Box Then PS1 = True
'実行
    Call AnswertoQ(scorepntBox, cmmtpnt, anspnt, PS1)

Unload Me

End Sub