Excelの条件付き書式を用いて、断面力分布や応力分布を3色のカラースケールで示し、最大値と最小値の発生位置を示すプロシージャを作成してみました。なお、ここで示したプロシージャはOffice2021を用いて作成しています。
メインプロシージャ
メインプロシージャでは、つぎのようなプロシージャを実行しています。
- データの読み込みとシートへのデータの書き込み
- 各データに罫線を書き込み
- 最大値と最小値を見つけて強調表示
- 3色のカラースケールを表示
”Sub データ読み込み（）”では、FEM解析等の出力テキストデータを読みこんで、シートにX座標、Y座標に対応する断面力等の値を書き込んでいます。この部分については、解析プログラムの出力書式に応じて作成する必要がありますので、ここでは冒頭の部分のみを示しています。なお、以下のプロシージャで使用している変数は、下記の緑文字の箇所をご覧ください。
Option Explicit '******************************************************** '* Nx：X方向分割数 Nx1：Nx+1 XL()：X座標 * '* Ny：Y方向分割数 Ny1：Ny+1 YL()：Y座標 * '* num：全データ数⇒ num = (Nx + 1) * (Ny + 1) * '* ip(図番,1)：sheet内の書き込み開始列番号 * '* ip(図番,2)：sheet内の書き込み開始行番号 * '* ip(図番,3)：テキストデータのデータ位置 * '******************************************************** Dim Nx As Long, Ny As Long, Nx1 As Long, Ny1 As Long, num As Long Dim i As Long, j As Long, k As Long, ii As Long, ij As Long, ip(4, 3) As Long Dim XL(50) As Double, YL(50) As Double Sub メインプログラム() Call データ読み込み Call 罫線書き込み Call 最大最小値表示 Call コンター着色 End Sub Sub データ読み込み() Dim FileName As Variant Dim A, B As String FileName = Application.GetOpenFilename() If FileName = False Then 'キャンセルボタンが押された場合に終了する End End If Workbooks.Add Open FileName For Input As #1 '--------- 解析ケース名 ---------------------------------------------- L1: Line Input #1, B A = Mid(B, 1, 9) (省略) End Sub
この例では、読み込んだデータを下図のようにsheet上に書き込んでいます。
また、Mx、My、Qx、Qyの4枚の図をsheet上に作成しています。
![[商品価格に関しましては、リンクが作成された時点と現時点で情報が変更されている場合がございます。]](https://hbb.afl.rakuten.co.jp/hgb/07312d98.cb8eea46.07312d99.cde59f81/?me_id=1213310&item_id=19705284&pc=https%3A%2F%2Fthumbnail.image.rakuten.co.jp%2F%400_mall%2Fbook%2Fcabinet%2F4103%2F9784865104103.jpg%3F_ex%3D240x240&s=240x240&t=picttext "[商品価格に関しましては、リンクが作成された時点と現時点で情報が変更されている場合がございます。]")
罫線を引く
罫線を引くプロシージャです。データ範囲を格子状に罫線を引き、ｙ座標とｘ座標の項目セルに右上がりの斜線を引いています。この例では、図面を4枚（For ij=1 To 4）作成し、各図面のセル位置を ip( , ) であらかじめ設定しています。そのため、このプロシージャを利用する際には、図面枚数やセル位置については新たに設定の必要があります。
Sub 罫線書き込み()
Dim ij1 As Integer, ij2 As Integer
Dim rng As Range '記述を簡便にするためにオブジェクト変数を設定
For ij = 1 To 4 '4つの範囲に対して実行
i = ip(ij, 1) '各セル範囲の開始行を指定
ii = i + Ny1
j = ip(ij, 2) - 1 '各セル範囲の開始列を指定
Set rng = Range(Cells(i, j), Cells(ii, j + Nx1))
rng.Borders.LineStyle = xlContinuous '格子状に罫線を描く
Set rng = Range(Cells(ii, j), Cells(ii, j))
rng.Borders(xlDiagonalUp).LineStyle = xlContinuous '右上がりの斜線を描く
Cells(ii, j) = " y x"
Next ij
End Sub最大・最小値箇所を強調
最大値と最小値の箇所を強調表示するためのプロシージャです。
まず、最大値と最小値を探してデータの上段に数値を記入します。その後、データ範囲で、記入した最大値と一致する箇所の文字を太字の斜文字とし、続けて記入した最小値と一致する箇所の文字を太字の斜文字として強調表示しています。
この例では図面を4枚（For ij=1 To 4）作成し、各図面のセル位置を ip( , ) であらかじめ設定しています。そのため、このプロシージャを利用する際には、図面枚数やセル位置については新たに設定の必要があります。また、複数の書式を設定しているので、書式をクリヤーすることができないため、”fcs(fcs.Count).SetFirstPriority” によって設定中の書式を先頭に持ってきて有効化する必要があります。
Sub 最大最小値表示()
Dim ij1 As Integer, ij2 As Integer
Dim rng As Range '記述を簡便にするためにオブジェクト変数を設定
Dim fcs As FormatConditions
'--------- 最大・最小値の検索 ----------------------------------------
Cells(ip(1, 1) - 1, ip(1, 2) - 1) = "Mx" '各図のタイトルを書き込み
Cells(ip(2, 1) - 1, ip(2, 2) - 1) = "My"
Cells(ip(3, 1) - 1, ip(3, 2) - 1) = "Qx"
Cells(ip(4, 1) - 1, ip(4, 2) - 1) = "Qy"
For ij = 1 To 4 '4つの範囲に対して実行
ij1 = ip(ij, 1) '各セル範囲の開始行を指定
ij2 = ip(ij, 2) '各セル範囲の開始列を指定
Set rng = Range(Cells(ij1, ij2), Cells(ij1 + Ny, ij2 + Nx))
Cells(ij1 - 1, ij2 + 2) = "Max"
Cells(ij1 - 1, ij2 + 2).HorizontalAlignment = xlRight '右詰め指示
Cells(ij1 - 1, ij2 + 3).NumberFormat = "0.00" 'フォーマット指示
Cells(ij1 - 1, ij2 + 3) = WorksheetFunction.Max(rng)
'各図の最大値を書き込み
Cells(ij1 - 1, ij2 + 5) = "Min"
Cells(ij1 - 1, ij2 + 5).HorizontalAlignment = xlRight
Cells(ij1 - 1, ij2 + 6).NumberFormat = "0.00"
Cells(ij1 - 1, ij2 + 6) = WorksheetFunction.Min(rng)
'各図の最小値を書き込み
Next ij
'--------- 最大・最小値の文字強調 ------------------------------------
For ij = 1 To 4 '4つの範囲に対して実行
ij1 = ip(ij, 1) '各セル範囲の開始行を指定
ij2 = ip(ij, 2) '各セル範囲の開始列を指定
Set rng = Range(Cells(ij1, ij2), Cells(ij1 + Ny, ij2 + Nx))
Set fcs = rng.FormatConditions
fcs.Add Type:=xlCellValue, Operator:=xlEqual, Formula1: _
=Cells(ij1 - 1, ij2 + 3) '最大値と同じセル位置を探して
fcs(fcs.Count).SetFirstPriority 'この書式を先頭（1番目）に設定
With fcs(1).Font '太字の斜文字フォントにする
.Bold = True
.Italic = True
End With
fcs(1).StopIfTrue = False '2つの書式を同時に適用して問題なし
fcs.Add Type:=xlCellValue, Operator:=xlEqual, Formula1: _
=Cells(ij1 - 1, ij2 + 6) '最小値と同じセル位置を探して
fcs(fcs.Count).SetFirstPriority 'この書式を先頭（1番目）に設定
With fcs(1).Font '太字の斜文字フォントにする
.Bold = True
.Italic = True
End With
Next ij
End Sub3色のカラースケールで着色
つぎのプロシージャは、3色のカラースケールの書式を各図面のデータ範囲に設定し、コンター図のように表示するものです。最大値最小値表示のプロシージャと同様に、図面を4枚（For ij=1 To 4）作成し、各図面のセル位置を ip( , ) であらかじめ設定しています。そのため、このプロシージャを利用する際には、図面枚数やセル位置については新たに設定の必要があります。また、複数の書式を設定しているので、書式をクリヤーすることができないため、”fcs(fcs.Count).SetFirstPriority” によって設定中の書式を先頭に持ってきて有効化する必要があります。
Sub コンター着色()
Dim ij1 As Integer, ij2 As Integer
Dim rng As Range '記述を簡便にするためにオブジェクト変数を設定
Dim fcs As FormatConditions
For ij = 1 To 4 '4つの範囲に対して条件付き書式を設定
ij1 = ip(ij, 1)
ij2 = ip(ij, 2)
Set rng = Range(Cells(ij1, ij2), Cells(ij1 + Ny, ij2 + Nx))
Set fcs = rng.FormatConditions
fcs.AddColorScale ColorScaleType:=3 '3色のカラースケールを指定
fcs(fcs.Count).SetFirstPriority 'この書式を先頭（1番目）に設定
With fcs(1).ColorScaleCriteria(1) '最低値の色を設定（緑）
.Type = xlConditionValueLowestValue
.FormatColor.Color = 7039480
End With
With fcs(1).ColorScaleCriteria(2) '中間値の色を設定（黄）
.Type = xlConditionValuePercentile
.Value = 50
.FormatColor.Color = 8711167
End With
With fcs(1).ColorScaleCriteria(3) '最大値の色を設定（赤）
.Type = xlConditionValueHighestValue
.FormatColor.Color = 8109667
End With
Next ij
End Sub以上、参考になれば幸いです。
コメント