のマクロです。
挙動
コード
➤回答転記のコード
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
flag = False ' PS1がTrueになっているときP6例外処理時の分岐変数
PS1i = 0 ' P6のPS1回答用変数
Set Qrng = ThisWorkbook.ActiveSheet.Range(Cells(2, "C"), Cells(ActiveSheet.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
回答転記に当たってはユーザーフォーム入力値から実行しています。
ユーザーフォームから呼び出す変数は、4つです（scorepntBox, cmmtpnt, anspnt, PS1)。
それぞれ、転記するスコアの場所、回答の場所、英文回答時用チェックボックス、PS1ある場合のチェックボックスです。PS1はVDAという国際自動車団体による固有チェックシートを目的としたチェックボックスです。
ポイント機能
・質問項番をもとにした転記回答の点数回答の転記
・項番からの位置による回答（点数とコメント）転記
・項番がなかった場合の処理
・オプション：英語回答、PS1がある場合（VDA対象）
質問項番をもとにした転記回答の点数回答の転記
質問ごとに振られる項番をもとに、点数と回答を転記しています。
これはVDA6.3のような、質問ごとに数字で項番が降られているチェックシートを対象にしています。
番号ではない場合も、キーとなる文字列があれば、転記元のテーブル項番の部分（C列）を回答用のチェックシートと一致させることで転記可能です。
マクロでは、topntとQpntを使用し回答を転記します。前者は回答用チェックシート項番のセル行の変数、後者は転記回答記載したファイルの項番のセル行の変数です。topntとQpntの値を比べ、一致している場合にQpntの回答をtopntの指定箇所に転記するロジックです。
上記のようにチェックシートの範囲、転記用回答の範囲から、変数を増減し項番を比較することで、回答を転記します。
rngは最初に選ぶ転記対象チェックシートの項番範囲が入り、Qrngにはマクロ実行時にC列に記載された項番の範囲が代入されています。
項番からの位置による回答（点数とコメント）転記
回答の転記場所は手動でテキストボックスに入れ処理します。
項番（回答転記するキーとなる文字列）を基準に、①点数と②コメントの箇所を数値で指定し、フォームのテキストボックスに入れます。
指定する数値は項番（キー）から離れたセルの個数です。例えば項番がA1で、点数とコメント位置がB2、C2
の場合は１と２と指定します。これによりオフセットをかけ、2つを転記しています。
点数がない或いは、コメントがない場合のチェックシートについては、どちらかで転記可能です。
指定場所に０か空欄のままにすることで転記をスキップします。
例えば、チェックシートに点数がなければ、点数場所のテキストボックスを空欄か0を記入すればよいです。
項番がなかった場合の処理
回答対象チェックシートに転記回答記載ファイルの項番がなかった場合は、前者の項番変数:topntを一つ進めていき、再度チェックシートで
キーの捜査をします（例えば転記回答記載ファイルに項番が1～５が記載されているが、チェックシートでは3がない場合を対象）。
これにより、チェックシートで一部設問がない場合でも回答転記が可能です。
再捜査の回数は変数anscntで判断し、6回まで再捜査を行います。
6回でも見つからない場合は、チェックシートにないと判断し、チェックシートのキー箇所（topnt）を一つ進め、転記回答記載ファイルのキー箇所（Qpnt）と比較を再度開始します。
チェックシートの質問が大幅に抜けている場合でも、VBEから6回の回数を増やせば対応できます。
オプション：英語回答、PS1がある場合（VDA対象）
ユーザーフォームのチェックボックスには、①英語回答と②PS1の場合の2つがあります。
①は転記回答を英語にしたい場合です。転記回答記載ファイルの和文回答の右側に英文を追加しておくことで
英文の追記が可能です。
②PS1については、VDAを対象にしたオプションです。通常項番の右側に点数とコメント欄があるのが通常ですが、
P6の箇所では項番の下にある「PS1」というワードの右に回答欄がある場合があります。P5の回答からP6に移る際
を判断条件として、P6の回答に入った場合はPS1をキーとして回答を転記する処理をしています。
PS1はP6に出現する特殊キーのため、QpntがP6になったタイミングで、PS1を転記キーとする処理をかけ、回答を転記しています。