Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Microsoft 365)
日付自動入力処理のWorksheet_Changeでの不具合の修正方法
投稿日時: 24/02/27 01:49:11
投稿者: やっ

・B列に入力があり、一つ上の行のA列に値があればそれをコピペ
(B10に入力してA9に値があればA9=A10にする)
・C列に入力があれば、一つ下のB列に移動する
(C10に入力があればB11に移動)
というものを以下のように書きました
A列は日付、B列は金額、Cは担当者IDです
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range
 
    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        Application.EnableEvents = False
        For Each cell In Target
            If cell.Offset(0, -1).Value = "" Then
                cell.Offset(0, -1).Value = cell.Offset(-1, -1).Value
            End If
        Next cell
        Application.EnableEvents = True
    End If
     
    If Not Intersect(Target, Me.Columns("C")) Is Nothing Then
        Application.EnableEvents = False
        For Each cell In Target
                cell.Offset(1, -1).Activate
        Next cell
        Application.EnableEvents = True
    End If
End Sub
 
しかしながら、以下の問題があります
 
1.行を選択して削除すると、TARGETの範囲がおかしくなりエラーがでる
2.デリートキーなどでB列の値を消去した場合も"変更"があったとみなされ、A列にコピペされてしまう
 
どのように修正したら解消できるでしょうか?
アドバイスよろしくお願いします

回答
投稿日時: 24/02/27 06:19:36
投稿者: simple

少々言いにくいことですが、新しい質問をする前に、するべきことがあるのではないですか?
https://www.moug.net/faq/viewtopic.php?t=82669
こちらは回答があっても、何のコメントもなしなんですか?
余りに虫が良すぎませんか?
最低限のマナーを守って頂けない方には、こちらからも回答を寄せにくいですよ。
返事をきちんとして下さい。
 
そちらが対価を払っている身分であればいざ知らず、回答者はボランティアの活動なので、
お互いにマナーを守ったうえで気持ち良く情報交換したいですね。

回答
投稿日時: 24/02/27 17:56:24
投稿者: WinArrow

引用:

1.行を選択して削除すると、TARGETの範囲がおかしくなりエラーがでる
 

エラー発生の場所と、エラー内容を説明しましょう。
  
「Worksheet_Change」イベントは、
「値が変わった時」と解釈していると、思わぬ落とし穴が待っています。
「値」が変る/変わらない・・・に関わらずイベントは発生します。
そのことを理解しましょう。
このプロシジャでは、「値」の変化を判断することはできない
と思いますので、
「値」の変化を判断する方法を再検討しましょう。

回答
投稿日時: 24/02/28 01:35:33
投稿者: hatena
投稿者のウェブサイトに移動

厳密には仕様としていろいろ問題がありそうですが、
とりあえず処理するセルの指定が間違ってます。
それを修正すればいちおう動作はします。
 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range

    Set rng = Intersect(Target, Me.Columns("B"))
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each cell In rng
            If cell <> "" And cell.Offset(0, -1).Value = "" Then
                cell.Offset(0, -1).Value = cell.Offset(-1, -1).Value
            End If
        Next cell
        Application.EnableEvents = True
    End If

    Set rng = Intersect(Target, Me.Columns("C"))
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each cell In rng
                cell.Offset(1, -1).Activate
        Next cell
        Application.EnableEvents = True
    End If
End Sub

投稿日時: 24/02/29 01:17:24
投稿者: やっ

ありがとうございます
間違いまで訂正していただき助かりました
少し触ったところ完璧に動作しているようですが
”仕様として問題がある”とはどのような部分でしょうか?
後学のために教えていただけると幸いです

トピックに返信