ter********

2021/2/23 13:47

22回答

マクロについて質問です。 下記のように対応する背景色の場合、塗りつぶされた色の3つ右のセルの値が削除されるようにしました。

マクロについて質問です。 下記のように対応する背景色の場合、塗りつぶされた色の3つ右のセルの値が削除されるようにしました。 １つのシートにこのコードが色別に7個あり、それと同じシートが8シートあります。 あまりにも容量が大きくなりすぎてしまったので小さくまとめたいのですが、どのようにすればよろしいでしょうか。 よろしくお願いいたします。 Sub DPClear() Dim WSheet As Worksheet Dim r As Integer Dim c As Integer Set WSheet = ThisWorkbook.Worksheets("A社") For c = 1 To COL_MAX For r = 1 To ROW_MAX If WSheet.Cells(r, c).Interior.ColorIndex = 35 Then WSheet.Cells(r, c + 3).ClearContents End If Next r Next c End Sub

Visual Basic・57閲覧・xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

ask********

カテゴリマスター

2021/2/26 17:43

こんな感じになります。 添付図を確認してください。 Sheet1 の A1:G1 に コマンドボタンを配置します。 (フォームコントロールを使用) セルにカラーインデックスを入力します。 ボタンをクリックしたらクリックしたボタンの名称を取得します。 ボタンの名称の右一文字を、セルの列番号指定として使用します。 左から順に、右一文字が 1,2,3,4,5,6,7 になるような名称にしてください。 ボタン1、ボタン2、ボタン3... セルの値が 1以上 55以下の場合に処理を行います。 処理対象シートは下記箇所で指定します。 Ary = Array("A社") '★Aシートのみ Ary = Array("A社", "B社","C社") -------------------------- ボタンを配置しているシートは下記で指定します。 Set ws1 = Worksheets("sheet1") '★ 処理対象範囲は下記で設定します。 Const Area1 As String = "a1:aw91" '★ カラーインデックスを検査する範囲です。 aw列で条件を満たした場合、右に三列移動したセル(az列)の値が消去されます。 Sub Sample1() '------------------------------ Const Area1 As String = "a1:aw91" '★ Dim ws1 As Worksheet Set ws1 = Worksheets("sheet1") '★ Dim Ary Ary = Array("A社") '★ 'Ary = Array("A社", "B社","C社") '------------------------------- Dim Bn As String Dim ws As Worksheet Dim v, xA Dim Rng As Range 'クリックしたボタンの名称を取得 Bn = Application.Caller '一番右の一文字を取得 v = Right(Bn, 1) 'セルの入力値を取得 v = ws1.Cells(1, CLng(v)).Value Select Case v Case 1 To 55 '1以上 55以下 For Each ws In Worksheets(Ary) With ws.Range(Area1) 'Area1を右方向に3列拡張した範囲の値を格納 xA = Union(.Cells, .Offset(, 3)).Value For Each Rng In .Cells If Rng.Interior.ColorIndex = v Then xA(Rng.Row, Rng.Column + 3) = "" End If Next Rng '結果をセルに返す Union(.Cells, .Offset(, 3)).Value = xA End With Next ws MsgBox "完了" Case Else MsgBox "インデックス未入力" End Select End Sub Sub ボタン1_Click() Sample1 End Sub Sub ボタン2_click() Sample1 End Sub Sub ボタン3_Click() Sample1 End Sub Sub ボタン4_click() Sample1 End Sub Sub ボタン5_click() Sample1 End Sub Sub ボタン6_Click() Sample1 End Sub Sub ボタン7_Click() Sample1 End Sub

画像

ThanksImg質問者からのお礼コメント

無事解決いたしました。 お二方とも本当にありがとうございました。

お礼日時：3/1 11:45

その他の回答（1件）

0

lgk********

2021/2/27 7:14

ボタンには背景色を付けれません。四角形でボタンもどきを作ります。 まず、ボタンもどきを入れたいシートでMacro1を実行して下さい。 A1～A7にボタンもどきができます。位置、サイズを好きな所へ変更して下さい。 以降、ボタンもどきを押すと処理がされます。 Macro2はボタンもどきの色を判断しています。直接動かすとエラーになります。 Option Explicit ' Sub Macro1()     Dim ColorIndexEs As Variant     Dim Cell As Range     Dim Co As Integer     Dim Shape As Shape '     ColorIndexEs = Array(43, 39, 6, 45, 40, 37, 35) '     For Each Cell In [A1:A7]         Set Shape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _             Cell.Left, Cell.Top, Cell.Width, Cell.Height)         Co = ColorIndexEs(Cell.Row - 1)         Shape.Fill.ForeColor.SchemeColor = Co + 7         Shape.TextFrame2.TextRange.Characters.Text = "色 " & Co & " 削除"         Shape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbBlack         Shape.TextFrame2.VerticalAnchor = msoAnchorMiddle         Shape.OnAction = "Macro2"     Next Cell End Sub ' Sub Macro2()     Dim Co As Integer     Dim Sheet As Worksheet     Dim Cell As Range '     If MsgBox("指定色の３つ右を消去します", vbOKCancel) = vbCancel Then         End     End If     Co = ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.SchemeColor - 7     Application.ScreenUpdating = False '     For Each Sheet In Worksheets '         For Each Cell In Sheet.[D1:AY91].SpecialCells(xlCellTypeConstants) '             If Cell.Offset(, -3).Interior.ColorIndex = Co Then                 Cell.ClearContents             End If     Next Cell, Sheet End Sub ' Sub Macro3()     Dim ColorIndexEs As Variant     Dim Sheet As Worksheet     Dim Cell As Range '     ColorIndexEs = Array(43, 39, 6, 45, 40, 37, 35) '     For Each Sheet In Worksheets '         For Each Cell In Sheet.[C1:C14]             Cell.Interior.ColorIndex = ColorIndexEs(Rnd * 7 - 0.5)             Cell.Offset(, 3) = "AAA"     Next Cell, Sheet End Sub