|
▼アオ さん:
あれっ、レイアウトの説明していただけたので、一応、考えてみましたが、
もっと、簡単にできないものかと、投稿を迷っていたら消えている。
削除されましたか?
Option Explicit
Sub test()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim wsC As Worksheet
Dim dic As Object
Dim 条件, 点数, 結果()
Dim j As Long, k As Long
Set wsA = Worksheets("A")
Set wsB = Worksheets("B")
Set wsC = Worksheets("C")
Set dic = CreateObject("scripting.dictionary")
条件 = wsA.Range("E6").Resize(30, 10).Value
For j = 1 To UBound(条件, 2)
For k = 1 To UBound(条件, 1)
If Not IsEmpty(条件(k, j)) Then dic(j) = dic(j) & " " & k
Next
Next
点数 = wsB.Range("A2:A100").SpecialCells(xlCellTypeConstants).Columns("I:AL").Value
ReDim 結果(1 To UBound(点数, 1), 1 To UBound(条件, 2))
For j = 1 To UBound(結果, 2)
For k = 1 To UBound(結果, 1)
If dic.exists(j) Then
With WorksheetFunction
結果(k, j) = .Average(.Index(点数, k, Split(.Trim(dic(j)))))
End With
End If
Next
Next
wsC.Range("D2").Resize(UBound(結果, 1), UBound(結果, 2)).Value = 結果
End Sub
|
|