質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.35%

  • VBA

    1902questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Worksheet_Changeについて教えて下さい。

受付中

回答 0

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 236

cd987456

score 24

エクセルの以下のシートがあります。
イメージ説明

やりたいことは
シートA列に「前倒し」「調整」「後倒し」を入れる。
入力した行の”注文残数”が”不足数合計”を超えたとき
同じアイテムコードを含む行を黄色くする。
イメージ説明
具体的には
アイテムコード「ミカン」の注番1を前倒し、注番2を調整とした時
それぞれの注文残数は”789”と”2000”で足すと”2700”で不足数合計”2668”を
超えます。そうすると、「ミカン」の行が黄色になります。

「メロン」は「前倒し」と記入した2つの注文残数が不足数合計を超えたので
注番6を記入しなくても「メロン」の行が黄色になります。

「リンゴ」は「前倒し」と記入していますが注文残数が不足数合計を超えていないので
行は着色されていません。

★コードを書いてみました。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim maxrow As Long, maxcol As Long
Dim myrow As Long, mycol As Long
Dim col1 As Long, col2 As Long, col3 As Long
Dim i As Long, j As Long

'最終行番
    With Range("A1").SpecialCells(xlLastCell)
       maxrow = .Row
    End With
'最終列番
    maxcol = Cells(2, Columns.Count).End(xlToLeft).Column
'「注文残数」列番
    Dim zansu As Range
    Set zansu = Rows(2).Find(what:="注文残数", LookAt:=xlWhole)
    If zansu Is Nothing Then
        Exit Sub
    Else
      col1 = zansu.Column
    End If
'「アイテムコード」列番
    Dim item As Range
    Set item = Rows(2).Find(what:="アイテムコード", LookAt:=xlWhole)
    If item Is Nothing Then
        Exit Sub
    Else
      col2 = item.Column
    End If
'「不足数合計」列番
    Dim husoku As Range
    Set husoku = Rows(2).Find(what:="不足数合計", LookAt:=xlWhole)
    If husoku Is Nothing Then
        Exit Sub
    Else
      col3 = husoku.Column
    End If
'選択したセルの行列番
    myrow = Target.Row
    mycol = Target.Column
'A列に入力した時、最終列の隣の列に1と入力する。    
    If mycol = 1 Then
        If Target.Value <> "" Then
            Cells(myrow, maxcol + 1).Value = 1
        ElseIf Target.Value = "" Then
            Cells(myrow, maxcol + 1).Value = ""
        End If
'A列に入力されている同一アイテムコードの注文残数合計
        i = WorksheetFunction.SumIfs(Range(Cells(3, col1), Cells(maxrow, col1)), Range(Cells(3, col2), Cells(maxrow, col2)), Cells(myrow, col2).Value, Range(Cells(3, maxcol + 1), Cells(maxrow, maxcol + 1)), 1)
'不足数合計
        j = Cells(myrow, col3).Value
        If i > j Then
            With Range(Cells(myrow, 1), Cells(myrow, maxcol)).Interior
                If .ColorIndex = xlNone Then
                   .Color = vbYellow
                Else
                   .ColorIndex = xlNone
                End If
            End With
        End If
    End If
End Sub

●教えてほしいことは
1.黄色に着色する箇所がアイテムコード全体とする方法が分かりません。
2.着色された行の「前倒し」などを消した時、不足数合計より注文残数が少なくなったら色を消す方法が分かりません。
3.1列目の複数のセルを選択して1回でDELETEすると
If Target.Value <> "" Thenでエラーになります。
回避できませんか

以上、3つについて教えて下さい。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正の依頼

  • ladybird

    2018/04/25 10:33

    イメージ説明がリンク切れになっています。修正いただけますでしょうか。(文章だけである程度予測つきますが、齟齬があるといけないので)

    キャンセル

  • baseballyama

    2018/05/18 11:21

    この質問は現在も回答を募集していますか?

    キャンセル

まだ回答がついていません

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.35%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る

  • VBA

    1902questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。