文字を入力すると違うシートに順番に表記する方法

質問

①シート1のセルC5に文字を手動で毎回入力すると、シート2のセルB5から下の列に順番に文字を自動で転送するVBAなどはどの様にすれば宜しいでしょうか？

②シート1のセルC6に文字を手動で毎回入力すると、シート2のセルC5から下の列に順番に文字を自動で転送するVBAはどの様にすれば宜しいでしょうか？

③同じ様な法則でシート1のセルC7に文字を手動で毎回入力すると、シート2のセルD5から下の列に順番に文字を自動で転送、シート1のセルC8に文字を手動で毎回入力すると、シート2のセルD5から下の列に順番に文字を自動で転送とする場合はどの様にすれば宜しいでしょうか？

④シート1のセルC5、C6、C7、C8に文字を手動で入力すると同じシート1の左隣のセルB5、B6、B7、B8に入力した回数を自動で表記する方法はありますか？

回答No.2

HohoPapa · ベストアンサー

こんなコードと思います。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim StrRow As Long
Dim TgtCol As Long
Dim MaxRow As Long
Dim ChgRow As Long
Dim PutSh1 As Worksheet
Dim PutSh2 As Worksheet
Dim PutSh3 As Worksheet
Dim PutCol As Long
Dim PutRow As Long
Dim ChgRng1 As Range
Dim ChgRng2 As Range
Dim ChgRng3 As Range

StrRow = 5
MaxRow = 35
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
Set PutSh1 = ThisWorkbook.Sheets("Sheet2")
Set PutSh2 = ThisWorkbook.Sheets("Sheet3")
Set PutSh3 = ThisWorkbook.Sheets("Sheet4")
With ThisWorkbook.Sheets("Sheet1")
Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列
Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列
Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列
End With

ChgRow = Target.Row

If Not Intersect(Target, ChgRng1) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh1, ChgRow, Target.Value
End If

If Not Intersect(Target, ChgRng2) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh2, ChgRow, Target.Value
End If

If Not Intersect(Target, ChgRng3) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh3, ChgRow, Target.Value
End If

End Sub

Sub DataPut(toSh As Worksheet, ChgRow As Long, tgdata As Variant)

Dim PutCol As Long
Dim PutRow As Long

PutCol = ChgRow - 3
PutRow = toSh.Cells(Rows.Count, PutCol).End(xlUp).Row + 1
If PutRow < 5 Then
PutRow = 5
End If
toSh.Cells(PutRow, PutCol).Value = tgdata

End Sub

お礼

ありがとうございます！
無事に解決出来ました。
また宜しくお願いします。

回答No.1

HohoPapa

後記コードをSheet1のモジュールに貼り付ければ
期待する動作になると思います。

なお、Sheet1のC列のどの行までが対象かのか未詳なので
20行目までのしています。

また、セルに埋める値が日付かどうかのチェックは行っていません。
例えば2022/1/1～2022/12/31の日付の場合に限って転記するのであれば
その条件を加える必要があります。

詳しくはコードを眺めてください。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

　Dim StrRow As Long
　Dim TgtCol As Long
　Dim MaxRow As Long
　Dim ChgCol As Long
　Dim ChgRow As Long
　Dim PutSh As Worksheet
　Dim PutCol As Long
　Dim PutRow As Long

　StrRow = 5
　TgtCol = 3
　MaxRow = 20
　Set PutSh = ThisWorkbook.Sheets("Sheet2")
　ChgCol = Target.Column
　ChgRow = Target.Row

　If Target.Count > 1 Then Exit Sub
　If ChgCol <> TgtCol Then Exit Sub
　If ChgRow < StrRow Then Exit Sub
　If ChgRow > MaxRow Then Exit Sub
　If Target.Value = "" Then Exit Sub

　PutCol = ChgRow - 3
　PutRow = PutSh.Cells(Rows.Count, PutCol).End(xlUp).Row + 1
　If PutRow < StrRow Then
　　PutRow = StrRow
　End If

　PutSh.Cells(PutRow, PutCol).Value = Target.Value
　Cells(ChgRow, ChgCol - 1).Value = Cells(ChgRow, ChgCol - 1).Value + 1

End Sub

お礼

ありがとうございます！
無事に解決出来ました。
また宜しくお願いします。

補足

ありがとうございます。
最後にもう一つ、転送先のシートを追加した場合の質問をさせて下さい。

①こちらのVBAで、シート1のセルE5：E36の範囲に文字を手動で毎回入力すると、シート3のセルB5から下の列に文字を自動で転送するものを追加する場合はどの様にすれば宜しいでしょうか？

②同じ様な法則でシート1のセルG6：G36に文字を手動で毎回入力すると、シート4のセルB5から下の列に文字を自動で転送するものを追加する場合はどの様にすれば宜しいでしょうか？

③シート1のセルB5の様に、シート1のセルE5、E6、E7、E8・・・とG6、G7、G8、G9・・・に文字を手動で入力すると、同じシート1の左隣のセルD5、D6、D7、D8・・・とF6、F7、F8、F9・・・に入力した回数を自動で表記するものを追加する場合はどの様にすればよろしいでしょうか？