Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Microsoft 365)
セルにグラデーションの分岐点を設定したい
投稿日時: 22/06/01 12:20:44
投稿者: ip8bk

いつもお世話になっております。
行き詰ってしまいまいましたので、こちらでお力を拝借させていただきます。
表題のグラデーションの分岐をセルに設定したいのですが、可能でしょうか?
図形では、vbaでも手動でも設定できるようですが、セルではどちらもやったことがないのと調べても出てこなかったのでご質問させていただきます。
ご存知の方おられましたら、ご教示お願いします。

回答
投稿日時: 22/06/01 13:28:41
投稿者: QooApp

図形に対する塗りつぶし設定>グラデーションの分岐点は自在制御できるようですが、
セルに対するグラデーションは2色の縦・横・各種斜め・角から・中央からのみの設定項目しか見つけられないのでできない仕様だと思います。
 
機能としてはホームタブ>フォントの詳細メニュー表示>塗りつぶしタブ>塗りつぶし効果>塗りつぶし効果ウィンドウ内の設定項目で確認できます。
 
操作方法についてはおそらく操作記録でソースコードのサンプルが取得できると思います。

回答
投稿日時: 22/06/01 14:09:18
投稿者: sk

引用:
グラデーションの分岐をセルに設定したい

(標準モジュール)
----------------------------------------------------------
Private Sub SetLinearGradient()
 
    Dim rng As Excel.Range
    Dim lgrd As Excel.LinearGradient
    Dim cs As Excel.ColorStop
     
    Set rng = Range("A1")
     
    '行の高さと列の幅を同じにする
    With rng
        .ColumnWidth = 30 '30文字分
        .RowHeight = .Width
    End With
     
    '塗りつぶしの設定
    With rng.Interior
        '塗りつぶしのパターンを線形グラデーションに
        .Pattern = xlPatternLinearGradient
        '線形グラデーションの場合、Gradient プロパティは
        'LinearGradient オブジェクトを返す
        Set lgrd = .Gradient
    End With
     
    '線形グラデーションの設定
    With lgrd
        'グラデーションの向きを角度で指定
        .Degree = 0
 
        '全てのカラーストップポイントをクリア
        .ColorStops.Clear
         
        '0%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0)
        '赤色にする
        cs.Color = vbRed
        Set cs = Nothing
         
        '50%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0.5)
        '緑色にする
        cs.Color = vbGreen
        Set cs = Nothing
         
        '100%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(1)
        '青色にする
        cs.Color = vbBlue
        Set cs = Nothing
 
    End With
     
    Set lgrd = Nothing
    Set rng = Nothing
 
End Sub
 
Private Sub SetRectangularGradient()
 
    Dim rng As Excel.Range
    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
     
    Set rng = Range("A2")
     
    '行の高さと列の幅を同じにする
    With rng
        .ColumnWidth = 30 '30文字分
        .RowHeight = .Width
    End With
      
    '塗りつぶしの設定
    With rng.Interior
        '塗りつぶしのパターンを矩形グラデーションに
        .Pattern = xlPatternRectangularGradient
        '矩形グラデーションの場合、Gradient プロパティは
        'RectangularGradient オブジェクトを返す
        Set rgrd = .Gradient
    End With
     
    '矩形グラデーションの設定
    With rgrd
        'グラデーションの収束先となるポイント/ベクトルの指定
        .RectangleTop = 0.25
        .RectangleLeft = 0.5
        .RectangleRight = 0.5
        .RectangleBottom = 0.75
         
        '全てのカラーストップポイントをクリア
        .ColorStops.Clear
         
        '0%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0)
        '白色にする
        cs.Color = vbWhite
        Set cs = Nothing
         
        '100%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(1)
        '黒色にする
        cs.Color = vbBlack
        Set cs = Nothing
 
    End With
     
    Set rgrd = Nothing
    Set rng = Nothing
 
End Sub
----------------------------------------------------------
 
以上のようなコードを記述したい、ということでしょうか。

投稿日時: 22/06/01 15:05:46
投稿者: ip8bk

天才的な速度で的確なご回答ありがとうございます。
できない可能性がありましたので、初めにご説明しておりませんでしたが、4つのセルを使って金属が反射しているよな動きを表現することを目的としてしています。
 
角度を変えたかったので、途中に下記のコードを追加しましたが、エラーになりました。
1つ目のLinearGradientでは問題なく動作しましたが、RectangularGradientではそのまま使えないのでしょうか?私の知識不足ですが、ご教示お願いいたします。
 
実行時エラー'438': オブジェクトはこのプロパティまたはメソッドをサポートしていません。
 

グラデーションの向きを角度で指定
Degree = 90

 
 
Private Sub SetRectangularGradient()
 
    Dim rng As Excel.Range
    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
     
    Set rng = Range("A2")
     
    '行の高さと列の幅を同じにする
    With rng
        .ColumnWidth = 30 '30文字分
        .RowHeight = .Width
    End With
      
    '塗りつぶしの設定
    With rng.Interior
        '塗りつぶしのパターンを矩形グラデーションに
        .Pattern = xlPatternRectangularGradient
        '矩形グラデーションの場合、Gradient プロパティは
        'RectangularGradient オブジェクトを返す
        Set rgrd = .Gradient
    End With
     
    '矩形グラデーションの設定
    With rgrd
        'グラデーションの向きを角度で指定
        .Degree = 90
        'グラデーションの収束先となるポイント/ベクトルの指定
        .RectangleTop = 0.25
        .RectangleLeft = 0.5
        .RectangleRight = 0.5
        .RectangleBottom = 0.75
         
        '全てのカラーストップポイントをクリア
        .ColorStops.Clear
         
        '0%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0)
        '白色にする
        cs.Color = vbWhite
        Set cs = Nothing
         
        '100%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(1)
        '黒色にする
        cs.Color = vbBlack
        Set cs = Nothing
 
    End With
     
    Set rgrd = Nothing
    Set rng = Nothing
 
End Sub

回答
投稿日時: 22/06/01 16:04:58
投稿者: sk

引用:
角度を変えたかったので、途中に下記のコードを追加しましたが、エラーになりました。
1つ目のLinearGradientでは問題なく動作しましたが、RectangularGradientでは
そのまま使えないのでしょうか?

引用:
Dim rgrd As Excel.RectangularGradient

引用:
'矩形グラデーションの設定
With rgrd
    'グラデーションの向きを角度で指定
    .Degree = 90

RectangularGradient オブジェクトに Degree プロパティはありません。
つまり、矩形グラデーションは線形グラデーションのように
角度を指定して回転させることが出来ないということ。
 
引用:
4つのセルを使って金属が反射しているよな動きを
表現することを目的としてしています。

基本的には、収束先を制御してそれっぽく見せかけるしかないでしょう。

投稿日時: 22/06/02 10:13:20
投稿者: ip8bk

ありがとうございます。
追加でご相談ですが、金がピカピカしている状態が表現できないか試しています。
 
下記の色の範囲をもう少し狭くしてみたいのですが、面積を変えることは可能でしょうか?
 

cs.Color = RGB(240, 240, 170)

 
Private Sub SetRectangularGradient()
 
    Dim rng As Excel.Range
    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
     
    Set rng = Range("a1:b2")
'    Application.ScreenUpdating = True
'    Application.ScreenUpdating = False
     
    '行の高さと列の幅を同じにする
    With rng
        .ColumnWidth = 30 '30文字分
        .RowHeight = .Width / 2
    End With
      
    '塗りつぶしの設定
    With rng.Interior
        '塗りつぶしのパターンを矩形グラデーションに
        .Pattern = xlPatternRectangularGradient
        '矩形グラデーションの場合、Gradient プロパティは
        'RectangularGradient オブジェクトを返す
        Set rgrd = .Gradient
    End With
    Dim i As Integer
    For i = 1 To 2
        '矩形グラデーションの設定
        With rgrd
            'グラデーションの収束先となるポイント/ベクトルの指定
            If i Mod 2 = 0 Then
                .RectangleTop = 0.75
                .RectangleLeft = 0.75
                .RectangleRight = 0.75
                .RectangleBottom = 0.75
            Else
                .RectangleTop = 0.25
                .RectangleLeft = 0.25
                .RectangleRight = 0.25
                .RectangleBottom = 0.25
             End If
            '全てのカラーストップポイントをクリア
            .ColorStops.Clear
             
            '0%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(0)
            '白色にする
            cs.Color = RGB(240, 240, 170)
    '        cs.Color = vbWhite
            Set cs = Nothing
             
            '100%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(1)
            '黒色にする
            cs.Color = RGB(150, 120, 30)
    '        cs.Color = vbBlack
            Set cs = Nothing
        End With
'        Set rgrd = Nothing
        Set rng = Nothing
        Application.ScreenUpdating = True
        Application.Wait [Now() + "00:00:00.2"]
    Next i
 
End Sub

回答
投稿日時: 22/06/02 11:35:10
投稿者: sk

引用:
下記の色の範囲をもう少し狭くしてみたいのですが、
面積を変えることは可能でしょうか?

引用:
'0%の位置にカラーストップポイントを追加
Set cs = .ColorStops.Add(0)
'白色にする
cs.Color = RGB(240, 240, 170)

0%寄りの位置にカラーストップポイントを追加して、
適当な中間色を設定なさればよろしいのではないでしょうか。
 
----------------------------------------------------------------
Sub SetRectangularGradient2()
  
    Dim rng As Excel.Range
    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
      
    Set rng = Range("A1:B2")
 
    Application.ScreenUpdating = False
     
    '行の高さと列の幅を同じにする
    With rng
        .ColumnWidth = 30 '30文字分
        .RowHeight = .Width / .Rows.Count
    End With
       
    '塗りつぶしの設定
    With rng.Interior
        '塗りつぶしのパターンを矩形グラデーションに
        .Pattern = xlPatternRectangularGradient
        '矩形グラデーションの場合、Gradient プロパティは
        'RectangularGradient オブジェクトを返す
        Set rgrd = .Gradient
    End With
 
    '矩形グラデーションの設定
    With rgrd
        'カラーストップポイントの初期化は1回でいい
        '(ループさせる必要はない)
 
        '全てのカラーストップポイントをクリア
        .ColorStops.Clear
          
        '0%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0)
        cs.Color = RGB(240, 240, 170)
        Set cs = Nothing
          
        '40%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(0.4)
        cs.Color = RGB(225, 180, 45)
        Set cs = Nothing
          
        '100%の位置にカラーストップポイントを追加
        Set cs = .ColorStops.Add(1)
        cs.Color = RGB(150, 120, 30)
        Set cs = Nothing
         
        Dim i As Integer
        For i = 1 To 2
            Application.ScreenUpdating = False
            'グラデーションの収束先となるポイント/ベクトルの指定
            If i Mod 2 = 0 Then
                .RectangleTop = 0.75
                .RectangleLeft = 0.75
                .RectangleRight = 0.75
                .RectangleBottom = 0.75
            Else
                .RectangleTop = 0.25
                .RectangleLeft = 0.25
                .RectangleRight = 0.25
                .RectangleBottom = 0.25
            End If
            Application.ScreenUpdating = True
            Application.Wait [Now() + "00:00:00.2"]
        Next i
    End With
 
    Set rgrd = Nothing
    Set rng = Nothing
 
End Sub
----------------------------------------------------------------

投稿日時: 22/06/02 12:39:01
投稿者: ip8bk

ご返信ありがとうございます。
中間色を追加することで解決できそうです。
 
一点お伺いしたいのですが、.RectangularGradientの存在はどこで情報収集されましたでしょうか?
最後に調べ方についてご教示お願いいたします。

回答
投稿日時: 22/06/02 15:52:25
投稿者: sk

引用:
RectangularGradientの存在はどこで情報収集されましたでしょうか?

関連してそうなクラスやメンバーをオブジェクトブラウザで検索して、
それぞれに関する記事を公式のリファレンスから参照しただけです。
 
https://docs.microsoft.com/en-us/office/vba/api/excel.rectangulargradient
https://docs.microsoft.com/en-us/office/vba/api/excel.lineargradient
https://docs.microsoft.com/en-us/office/vba/api/excel.colorstops

回答
投稿日時: 22/06/03 13:00:51
投稿者: MMYS

機械翻訳ですが、日本語訳はこちら
https://docs.microsoft.com/ja-jp/office/vba/api/excel.rectangulargradient
https://docs.microsoft.com/ja-jp/office/vba/api/excel.lineargradient
https://docs.microsoft.com/ja-jp/office/vba/api/excel.colorstops
 
 
また、オブジェクトに、どのようなプロパティやメソッドが存在するかは、公式リファレンスで確認しましょう。たとえば
 

ip8bk さんの引用:

実行時エラー'438': オブジェクトはこのプロパティまたはメソッドをサポートしていません。

といった疑問は、RectangularGradient オブジェクト。のプロパティの項目を確認します。
https://docs.microsoft.com/ja-jp/office/vba/api/excel.rectangulargradient
 
プロパティ
・Application
・ColorStops
・Creator
・Parent
・RectangleBottom
・RectangleLeft
・RectangleRight
・RectangleTop
 
以上のことから、RectangularGradient オブジェクトに Degreeプロパティが無いことが分かります。
 
また、オブジェクトブラウザで RectangularGradient で検索すれば、実際の実装から、プロパティやメソッドの情報を取得しますので、オブジェクトブラウザを使うと、どなんプロパティやメソッドが実装さているかが分かります。
 
なお、ドキュメントは実装とは別に作成されます。ですから、稀に実装とドキュメントが一致しないことがありますので、実際にオブジェクトにどのようなプロパティやメソッドが実装されているかの確認は、オブジェクトブラウザで確認しましょう。
 
 

投稿日時: 22/06/10 08:50:11
投稿者: ip8bk

ご回答ありがとうございます。
公式リファレンス読み込みました。
 

引用:
また、オブジェクトブラウザで RectangularGradient で検索すれば、実際の実装から、プロパティやメソッドの情報を取得しますので、オブジェクトブラウザを使うと、どなんプロパティやメソッドが実装さているかが分かります。

 
認識していないオブジェクトを見つけ出すところが難しいですが、今後は質問前にオブジェクトブラウザと公式リファレンスを確認します。
 
ご教示いただきました、皆様大変ありがとうございました。
お返事が遅くなりましたことお詫び申し上げます。