回答受付が終了しました

Excel VBAで下記内容は配列で実現できますでしょうか? やりたいこと:

Visual Basic | Excel96閲覧xmlns="http://www.w3.org/2000/svg">250

回答(2件)

0

最初の回答者の方のデータをまるパクリしました。 そっち(配列を使わない)のほうが作業列とか使ってうまく処理されており初心者の方にはずっと分り易いだろうなとは思ったのですが 一応配列を使ったやり方も上げておきます。 シートのデータを配列に取り込むやり方を2種類用意しました。 直値(範囲をコードで直に指定。データの増減のたびに直す手間がいる)と 自動判別(データの左上だけ指定すると勝手に判別する)です。好きなほうを使ってください。 Option Explicit Sub subMain() Dim ary材, aryPh, aryPhSum, ary材Total, aaa Dim lng材Row, lng材Col, lngPhRow, ubndCol, ubndPhRow Call subSetArray(aryPh, ary材) 'またはsubSetArray直値(aryPh, ary材) ReDim aryPhSum(1 To UBound(aryPh, 1)) ReDim ary材Total(1 To UBound(ary材, 1)) ubndCol = UBound(ary材, 2) ubndPhRow = UBound(aryPh, 1) For lng材Row = 1 To UBound(ary材, 1) For aaa = 1 To UBound(aryPhSum) aryPhSum(aaa) = 1 Next For lng材Col = 1 To ubndCol Select Case ary材(lng材Row, lng材Col) Case "〇", "○", "◎", "О" '漢字の〇、記号の〇、◎、アルファベットのО For lngPhRow = 1 To ubndPhRow aryPhSum(lngPhRow) = aryPhSum(lngPhRow) * aryPh(lngPhRow, lng材Col) Next Case "×", "X", "x" '記号の×、アルファベットのX、全角のx Case Else MsgBox ary材(lng材Row, lng材Col) & " 未知の記号がありました終了します。" Exit Sub End Select Next ary材Total(lng材Row) = WorksheetFunction.Sum(aryPhSum) Next ThisWorkbook.Sheets("数値シート").Cells(2, 2).Resize(UBound(ary材Total), 1) = WorksheetFunction.Transpose(ary材Total) End Sub Sub subSetArray(ByRef aryPh, ByRef ary材) '表の前提条件の確認と配列のセット。データの左上のセルを指定すればデータ範囲を自動で判別する。 Dim lngEndRow材, lngEndCol材, lngEndColPh, lngEndRowPh Dim strItemPh, strItem材 Dim vlnHitRow, aaa, bbb, ccc, rrr, rngDataStartPh, rngDataStart材 Dim shtPh, sht材 Set shtPh = ThisWorkbook.Sheets("確認シート") Set sht材 = ThisWorkbook.Sheets("数値シート") With shtPh Set rngDataStartPh = .Cells(2, 2) '適宜変えてくださいデータの最左上 If .AutoFilterMode Then .AutoFilter.ShowAllData lngEndColPh = rngDataStartPh.End(xlToRight).Column lngEndRowPh = rngDataStartPh.End(xlDown).Row aaa = .Range(rngDataStartPh.Offset(-1, 0), rngDataStartPh.Offset(-1, 0).End(xlToRight)).Value strItemPh = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(aaa)), ",") aryPh = .Range(rngDataStartPh, .Cells(lngEndRowPh, lngEndColPh)).Value End With With sht材 Set rngDataStart材 = .Cells(2, 3) '適宜変えてくださいデータの最左上 If .AutoFilterMode Then .AutoFilter.ShowAllData lngEndCol材 = rngDataStart材.End(xlToRight).Column lngEndRow材 = rngDataStart材.End(xlDown).Row aaa = .Range(rngDataStart材.Offset(-1, 0), rngDataStart材.Offset(-1, 0).End(xlToRight)).Value If strItemPh <> Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(aaa)), ",") Then MsgBox "項目が一致しません" Exit Sub End If ary材 = .Range(rngDataStart材, .Cells(lngEndRow材, lngEndCol材)).Value End With If UBound(ary材, 2) <> UBound(aryPh, 2) Then MsgBox "データ数が一致しません" Exit Sub End If End Sub Sub subSetArray直値(ByRef ary確, ByRef ary数) 'subSetArrayと同じ内容を直値で指定するとこんなに単純になる。ただ、データが増えたり減ったりしたら手動でコードを変えなくてはならない。 ary確 = ThisWorkbook.Sheets("確認シート").Range("B2:F6").Value 'データ範囲。適宜変えてください ary数 = ThisWorkbook.Sheets("数値シート").Range("B2:F4").Value '適宜変えてください End Sub

画像
1

他の方々は、マクロの関数を使用して回答されていますが、マクロの関数の知識がないためIf文と繰り返しのみの回答となりますので,ちょっと見づらいかと思います。 貴方の要望は、「材料ごとに、数値シートで○がついている項目の値を確認シートで取得し、すべて掛け算し、全フェーズの結果を足す。(材料1なら20×15×20…+40×20×10…)」とのことですが、 私の理解に間違いないと考えますが、添付図の「確認シート」の「J列」、「K列」、「L列」に数値シートの例題で手計算を行なった結果を書いています。これはまたプログラムの実行結果が間違いないかの検証のための覚え書きですので、あとは無視下さい。 理解が間違っていなければ、以降のプログラムの説明にお進み下さい。 1.プログラムの流れ説明の前に次の点をご了承下さい。 プログラム実行時の補助として、確認シートの1列目に各フェーズ毎の掛け算の集計結果を一時的に記録させることとしています。 プログラム内で書き込んだり、消したりしますので実質的には何も扱う必要はありません。(添付図参照) 2.確認シートと数値シートの項目数: 確認シートの項目数と数値の項目数が異なっても実行上問題はありません。 当然、確認シートの項目数>=数値シートの項目数でなければなりませんが。 また、必要な項目までは確実に「○」か「×」を書込み、途中に空白セルを作らないようにして下さい。 「空白」があればその時点でプログラムは次に移りますので。 3.数値シートの材料数は、変数「n0」で1,000行目まで書込みを行なっても対応するようにしています。 4.項目A、B、C、・・・の項目数は、項目数が70項目ほどあるとのことで、変数「y0」で「70」までとし対応するようにしています。 5.フェーズの数は特に指定は無かったのですが、これも変数「n1」で1,000行目まで書き込んでも対応できるようにしています。 変数n0、y0、n1、がマックスとなった場合の処理時間はどの程度掛かるか分りませんが。 プログラムは、フォームコントロールのボタンに書き込まれています。 プログラムの実行結果は添付図を参照下さい。 Sub ボタン1_Click() With Worksheets("確認") 'リセット Range(Cells(3, 2), Cells(1000, 2)).Value = "" Range(.Cells(2, 1), .Cells(1000, 1)).Value = "" For n0 = 3 To 100 If Cells(n0, 1).Value = "" Then Exit For Else Range(.Cells(2, 1), .Cells(1000, 1)).Value = "" For y0 = 1 To 70 If Cells(n0, 2 + y0).Value = "" Then Exit For ElseIf Cells(n0, 2 + y0).Value = "○" Then For n1 = 2 To 1000 If .Cells(n1, 2).Value = "" Then Cells(n0, 2).Value = WorksheetFunction.Sum(Range(.Cells(2, 1), .Cells(n1 - 1, 1))) Exit For Else If .Cells(n1, 1).Value = "" Then .Cells(n1, 1).Value = .Cells(n1, 2 + y0).Value Cells(n0, 2).Value = Cells(n0, 2).Value + .Cells(n1, 1).Value Else .Cells(n1, 1).Value = .Cells(n1, 1).Value * .Cells(n1, 2 + y0).Value Cells(n0, 2).Value = Cells(n0, 2).Value + .Cells(n1, 1).Value End If End If Next End If Next End If Next End With End Sub

画像

1人がナイス!しています