| |
こんにちは。かみちゃん です。
>>>解析されたデータをCSVで取得して目視で最大絶対値の拾い出しをおこなっているのですがマクロでデータの拾い出しを考えています。
>>>条件としては、各項目毎（曲げ関係、軸力・座屈関係等）にデータが作成されます。項目毎の特定の材料の最大絶対値を取得したいのですが中々わかりません。
>>
>>求めたいのは、下表で
>>・A2セルとC2セルを指定すると、D2セルが求められる
>>・A3セルとC3セルを指定すると、D3セルが求められる
>>ということですか？
>
>はい、そうです。
一例として、以下のような感じでできると思います。
Sub Sample()
Dim WS As Worksheet
Dim rngData As Range
Dim vntData As Variant
Dim rngFind As Range
Dim y As Long
Dim rngList As Range
Dim rngStart As Range
Dim rngEnd As Range
Dim v As Variant
Dim yyy As Long
Dim yy As Long
Dim xx As Long
Dim vntList As Variant
Set WS = ActiveSheet
'抽出条件の範囲
Set rngData = WS.Range("A1:I30")
vntData = rngData.Formula
'貼り付けデータがある範囲（30行目は、空白行とし、貼り付けデータ内には、行全体または列全体が空白の行または列がないこと）
Set rngFind = WS.Range("A31").CurrentRegion
For y = 1 To UBound(vntData, 1)
If vntData(y, 1) Like "*関係" Then
'最大値検索範囲の取得
Set rngList = Nothing
Set rngStart = rngFind.Columns(1).Find(What:=vntData(y, 1), After:=rngFind.Cells(1, 1))
If Not rngStart Is Nothing Then
Set rngEnd = rngFind.Columns(1).Find(What:="*関係", After:=rngStart)
If Not rngEnd Is Nothing Then
If rngEnd.Row < rngStart.Row Then
Set rngEnd = rngFind.Cells(rngFind.Rows.Count, 1)
End If
Else
Set rngEnd = rngFind.Cells(rngFind.Rows.Count, 1)
End If
Set rngList = Range(rngStart.Cells(1, 1), rngEnd.Cells(0, 1)).Resize(, rngFind.Columns.Count)
End If
'最大値検索範囲があったら、
If Not rngList Is Nothing Then
v = rngList.Value
yyy = 0
ReDim vntList(1 To UBound(v, 1), 1 To UBound(v, 2))
For yy = 1 To UBound(v, 1)
'検索範囲内の「材料No」が抽出条件の「材料No」に一致している場合
If CStr(v(yy, 3)) = CStr(vntData(y, 3)) Then
yyy = yyy + 1
For xx = 1 To UBound(v, 2)
If IsNumeric(v(yy, xx)) Then
'マイナス数値の場合、絶対値に変換のため -1 を乗算
If v(yy, xx) < 0 Then
vntList(yyy, xx) = v(yy, xx) * -1
Else
vntList(yyy, xx) = v(yy, xx)
End If
Else
vntList(yyy, xx) = v(yy, xx)
End If
Next
End If
Next
End If
'4列目から最大値を取得
For xx = 4 To UBound(vntList, 2)
vntData(y, xx) = Application.WorksheetFunction.Max(Application.WorksheetFunction.Index(vntList, 0, xx))
Next
End If
Next
'最大値を出力
rngData.Formula = vntData
End Sub
|
|
かみちゃん
- 11/9/22(木) 16:51 -
