Excelで、特定セルに張り付けると特定セルに追番で数字が入るマクロに下記を追加したい

Question

Excelにて、コピーして特定セルに張り付けると、特定セルに追番で数字が
入るマクロに下記内容を追加したいのですが、どのように追加修正してよいのか
分からず苦慮しております。


現在は、A～Kを使用しており、Dにコピーしたデーターを貼り付けるとKのセル
に１～追番で数字が入力されます。
sheet１行目には、項目名があり ２行目から入力となります

追加項目
１５行以内をコピーしてD列に貼り付けたら、今まで通り追番で数字が入り
１５行以上であれば15行毎に＋1するようにしたい。

例えば、61行貼り付けたとすると
1～15行は今まで通り、16～３０行目は15行目の数字に＋１
３1～４５行は、３０行目の数字に＋１
４６～６０行は、４5行目の数字に＋１

という具合に、15毎に、K列に追番で数字を入れたい。


説明が下手ですみません


お分かりになられる方ご教授願います。

現在のコード

Private Sub Worksheet_Change(ByVal Target As Range)
Dim no As Long
Dim rng As Range
If Target.Row = 1 Or Target.Column <> 4 Then Exit Sub
If Range("K5").Value = "" Then
no = 1
Else
no = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row).Value + 1
End If
Application.EnableEvents = False
For Each rng In Target
If rng.Value = "" Then
rng.Offset(0, 7).Value = ""
Else
rng.Offset(0, 7).Value = no
End If
Next rng
Application.EnableEvents = True
End Sub

Qchan1962 · Accepted Answer

エラーの想定できる原因、回避のヒントは＃６に書いた通りですが、仕様が解らないので実際にどのようにすれば良いか、、ファイルをどのように弄っているのか、、、表中の値を削除や書き直しなどされるのかとか、、K列のみ手入力で値を操作（文字、関数　入力や空白など）したりするとか＞入力した内容を取り消したりすると次に貼り付けると13エラーがでます。エラーが出る時のセルの値は何でしょう？ブレイクポイントを設けるとかイミディエイトウィンドウで確認するとかしてデバッグしましょう。今までのコードで問題が発生していないのなら no = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row).Value + 1 に書き替えればエラー箇所まで同じになると思いますが、、ご質問部分以外を変えたのが悪かったのかも知れません。 If Target.Row = 1　なども気になるのでもう一度全部で考えて K列該当セルの値が数値でなければ+1されないようにしたものです +1にする必要がある場合は、さらに上行方向に値が数値のセルまでループして探すとかになると思います。表中の行の場合、K列一番下の数値に出来る行が+1対象です。そのセルの値が数値に出来ない値の場合、+1されません。（1が入る） Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, no As Long: no = 1 Dim Rng As Range If Target.Row < 5 Or Target.Column <> 4 Then Exit Sub If Range("K5").Value <> "" Then Set Rng = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row) If IsNumeric(Rng) Then no = Rng.Value + 1 End If End If Application.EnableEvents = False For i = 1 To Target.Count If Target(i).Value = "" Then Target(i).Offset(0, 7).ClearContents Else If i > 1 And Int(i - 1) Mod 15 = 0 Then no = no + 1 Target(i).Offset(0, 7).Value = no End If Next i Application.EnableEvents = True End Sub

のろまなカメ · Answer

offset(0,15)を使えないかな？

Qchan1962 · Answer

こんにちは
＞1～15行は今まで通り、16～３０行目は15行目の数字に＋１
３1～４５行は、３０行目の数字に＋１
４６～６０行は、４5行目の数字に＋１　その後も15行ごとに+1

説明と少し違うような気がしますが思い違いと思うので

16行目以降の処理は　例として

If rng.Value = "" Then
            rng.Offset(0, 7).Value = ""
        Else
            If rng.Row > 15 Then
                no = Application.RoundUp(rng.Row / 15 - 1, 0)
                rng.Offset(0, 7).Value = no + Range("K15").Value
                Else
                rng.Offset(0, 7).Value = no
            End If
        End If
    Next rng

ご質問を取り違えているかも知れませんが、こんな感じでどうでしょう。

Qchan1962 · Answer

#2
例として挙げましたが
no = Application.RoundUp(rng.Row / 15 - 1, 0)
整数部分を作るより、よく使うのはこちらかも、、整数部分を取り出す
no = Int((rng.Row - 1) / 15)
-1は16行目からなので

Qchan1962 · Answer

連投失礼します。
補足ありがとうございます
画像を見るとご質問に示されているコード処理と結果が違うと思うのですが、
If Range("K5").Value = "" Then
no = 1
2度目の貼り付け（青）の時　K5は””ですよね。
なので　1となるのではないでしょうか？Else　の
no = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row).Value + 1
は、実行されないと思いますが、いかがでしょう？
If Range("K4").Value = ""と変えてみては？
いずれにしても、
回答は、15行より上の処理は触っていません。

ただ、やはりなさりたい事を理解できていなかったと言う事のようですね

＞61行貼り付けたとすると1～15行は今まで通り

16行目以降はすでに示した通りですが、2行目から15行目は
一度にペーストするとすべてに1が入るコードになっていると思うのですが
61行をペーストした時に2行目から15行目はどのようになるのですか？
コードからしか判断できませんので、期待する結果を教えてください。

16行目以降の処理結果は　　３1～４５行は、３０行目の数字に＋１などと
同じだと思いますので
16～３０行目は15行目の数字に＋１
３1～４５行は、15行目の数字に＋2
４６～６０行は、15行目の数字に＋3
と言う考え方です。

一応、プロシージャを（画像も）ご確認ください。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim no As Long
    Dim rng As Range
    If Target.Row = 1 Or Target.Column <> 4 Then Exit Sub
    If Range("K4").Value = "" Then
        no = 1
    Else
        no = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row).Value + 1
    End If
    Application.EnableEvents = False
    For Each rng In Target
        If rng.Value = "" Then
            rng.Offset(0, 7).Value = ""
        Else
            If rng.Row > 15 Then
                no = Int((rng.Row - 1) / 15)
                rng.Offset(0, 7).Value = no + Range("K15").Value
            Else
                rng.Offset(0, 7).Value = no
            End If
        End If
    Next rng
    Application.EnableEvents = True
End Sub

Qchan1962 · Answer

こんばんは、
思っていたのと大分違っていたようで、、
For Each rng In Target　からのrng相対位置を取得する方法が、、どうだったか、
ちょっと思考放棄をしてループを変えてしまいました。
お好みでないかも知れませんが、上記（思考放棄部分）を調べてみてください。

処理自体は、こんな感じで良さそうですが、どうでしょう。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim no As Long
Dim i As Long
    If Target.Row = 1 Or Target.Column <> 4 Then Exit Sub
    If Range("K5").Value = "" Then
        no = 1
    Else
        no = Cells(Rows.Count, "K").End(xlUp).Value + 1
    End If
    Application.EnableEvents = False
    For i = 1 To Target.Count
        If Target(i).Value = "" Then
            Target(i).Offset(0, 7).Value = ""
        Else
            If i > 1 And Int(i - 1) Mod 15 = 0 Then
                no = no + 1
            End If
            Target(i).Offset(0, 7).Value = no
        End If
    Next i
    Application.EnableEvents = True
End Sub

ちょっと、酔いが、、違っていたら
 Else
            If i > 1 And Int(i - 1) Mod 15 = 0 Then
                no = no + 1
            End If
            Target(i).Offset(0, 7).Value = no
        End If
の部分だと思いますので考えてくださいね。

Qchan1962 · Answer

こんにちは

13エラーですか、考えられるのは+1をしようとしているセルの値が
""だったり文字など四則演算出来ないケースだと思うのですが、
K列の下の方に関数式や文字入力の残りなど無いですか？

ちなみに
no = Range("K" & Cells(Rows.Count, "K").End(xlUp).Row).Value + 1
でもエラーになると思うのですが、、
違う原因だったらごめんなさい。

想定対応としてK列のTarget行から下を一度クリアーするなど、、
いや、ちょっと雑な気がします
数値が入っている事を検証して+1するとか、、数値でなければ
更にそのセルから.End(xlUp)・・

VBAで上行から数値が振られていく処理ならば、（空白行が出来ないのなら）
考え方を変えて　下記の様にするとどうでしょう。
仕様に合わなくなるようでしたら、検討が必要ですが

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, no As Long: no = 1
If Target.Row = 1 Or Target.Column <> 4 Then Exit Sub
If Range("K5").Value <> "" Then
no = Range("K5").End(xlDown).Value + 1
End If
Application.EnableEvents = False
For i = 1 To Target.Count
If Target(i).Value = "" Then
Target(i).Offset(0, 7).Value = ""
Else
If i > 1 And Int(i - 1) Mod 15 = 0 Then no = no + 1
Target(i).Offset(0, 7).Value = no
End If
Next i
Application.EnableEvents = True
End Sub

Excelで、特定セルに張り付けると特定セルに追番で数字が入るマクロに下記を追加したい

offset(0,15)を使えないかな？

こんにちは

#2

連投失礼します。

こんばんは、

こんにちは

エラーの想定できる原因、回避のヒントは＃６に書いた通りですが、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング