Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1153 / 76734 ←次へ | 前へ→

【81236】Re:VBAの列の空白と1の認識をループする方法について
発言  マナ  - 20/3/21(土) 23:33 -

引用なし
パスワード
   ▼アオ さん:

あれっ、レイアウトの説明していただけたので、一応、考えてみましたが、
もっと、簡単にできないものかと、投稿を迷っていたら消えている。
削除されましたか?

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
3 hits

【81234】VBAの列の空白と1の認識をループする方法について アオ 20/3/20(金) 22:13 質問[未読]
【81235】Re:VBAの列の空白と1の認識をループする方... マナ 20/3/21(土) 17:16 発言[未読]
【81236】Re:VBAの列の空白と1の認識をループする方... マナ 20/3/21(土) 23:33 発言[未読]

1153 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free