VBAを使っての最大値の求め方を教えて下さい

Question

VBAを使っての最大値の求め方を教えて下さい

Anonymous

見にくくて申し訳ないんですが、下記の表においてA~Cの最大値を右サイドに抜き出すコードを教えて下さい。最初に回数の最大値を求めて、かつ　％>= 50であれば最大値とします。結果1においてはC列の6回、75％がそれに相当します。なお、結果2の様にA列、B列同様の数値であれば若番のA列を優先することとします。

　　　　　A 　　　　 B 　　　C 　　　　D 　　　E 　　最大値

　　回数　％　　　回数　％　　　回数　％　　　回数　％　　　回数　％　　　回数　％　　　結果1 　 5 　 34　　　 5 　 71 　　　 6 　 75 　　　 6　　 50 　　　2 　　50 　　　　　　　　

結果2 　 3 　 100　　 3 100 1 25 1 50

できるだけ簡単なコードにて、よろしくお願いいたします。

ロックされた質問。この質問は、Microsoft サポートコミュニティから移行されました。役に立つかどうかに投票することはできますが、コメントの追加、質問への返信やフォローはできません。

0 件のコメント

質問作成者が受け入れた回答

Anonymous

こうすれば、まず結果1の最大回数はmax関数で一瞬で出ます（6）。

また、最大回数の内、%の最大値は、Maxifs関数で出せます。

=MAXIFS(%の範囲、回数の範囲、回数の最大値（6）)で、最大回数が6で%が50の場合と、最大回数が6で%が75の場合の、%が最大値である、「75」が弾き出されます。

0 件のコメント

2 件の追加の回答

Answer 1

Yuki M.様

　先日の1/12のアドバイスについてお礼を申し上げます。

いろいろ考えた挙句、最終的にYuki M.様の助言に従うのが最適かなと考え、横書きの表を縦型に作り変えました。表の書き換えまたコードの作成などに、かなりの時間を要しましたがやっと一つのハードルをクリアすることが出来ました。あのアドバイスがなければ未だに放浪していたことでしょう。有難うございます。なお、先程満足度の星印の記入欄で星を1つしか押せなかったことをお詫び申し上げます。左から一つずつ押していこうかとやっていたらすぐさま送信され、一つ目の星を付けることしか出来ませんでした。気分を害されていいることと思われますが、何分ご容赦くださいませ。ボタンの押し方がおかしいので私だけでなく、他の人でも失礼な送信をしてしまう可能性があるかと思います。星印を確定してから送信できるように改めては如何ですか？　私はこれで2回目の失態を重ねていますので、送信後は取り返しのつかない状態になっています。

　最後に、今回私が作ったコードを参考までに貼付しました。相当な時間を要したもののアドバイスのお陰で、最短のやり方でクリア出来たことを改めて感謝申し上げます。

'select2

Sub select2B()

Dim j As Long

Dim selc2B As Worksheet

Set selc2B = Worksheets("select2B")

With Worksheets("select2")

lRow = .Cells(Rows.Count, 1).End(xlUp).Row

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j, 5).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "1 - 1", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), 1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 1, 5).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "2 - 3", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), 1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 2, 5).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "4 - 6", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), 1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 3, 5).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "7 - 10", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), 1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 4, 5).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "11- end", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), 1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j, 6).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "1 - 1", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), -1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 1, 6).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "2 - 3", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), -1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 2, 6).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "4 - 6", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), -1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 3, 6).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "7 - 10", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), -1)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j + 4, 6).Value = WorksheetFunction.CountIfs( _

.Range(.Cells(10, 6), .Cells(lRow, 6)), selc2B.Cells(j, 1), _

.Range(.Cells(10, 3), .Cells(lRow, 3)), selc2B.Cells(j, 2), _

.Range(.Cells(10, 4), .Cells(lRow, 4)), selc2B.Cells(j, 3), _

.Range(.Cells(10, 11), .Cells(lRow, 11)), "11- end", _

.Range(.Cells(10, 2), .Cells(lRow, 2)), -1)

'G列 = E列+F列

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB

Cells(j, 7) = Cells(j, 5) + Cells(j, 6)

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB

If selc2B.Cells(j, 7).Value <> 0 Then 'ゼロ除算回避

selc2B.Cells(j, 8).Value = selc2B.Cells(j, 5).Value / selc2B.Cells(j, 7).Value * 100

Else

selc2B.Cells(j, 8).Value = 0

End If

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB

If selc2B.Cells(j, 5).Value - selc2B.Cells(j, 6).Value > 1 Then

selc2B.Cells(j, 9).Value = selc2B.Cells(j, 5).Value - selc2B.Cells(j, 6).Value

selc2B.Cells(j, 10).Value = selc2B.Cells(j, 8).Value

Else

selc2B.Cells(j, 9).Value = ""

selc2B.Cells(j, 10).Value = ""

End If

lRowB = selc2B.Cells(Rows.Count, 1).End(xlUp).Row

For j = 10 To lRowB Step 5

selc2B.Cells(j, 14).Value = WorksheetFunction.Max( _

selc2B.Range(selc2B.Cells(j, 9), selc2B.Cells(j + 4, 9)).Value)

If Cells(j, 14) > 0 Then

h = WorksheetFunction.Match( _

selc2B.Cells(j, 14), Range(selc2B.Cells(j, 9), selc2B.Cells(j + 4, 9)), 0)

Cells(j, 15).Value = Cells(j + h - 1, 10).Value

Cells(j, 11).Value = Cells(j + h - 1, 1).Value

Cells(j, 12).Value = Cells(j + h - 1, 2).Value

Cells(j, 13).Value = Cells(j + h - 1, 3).Value

selc2B.Range(Cells(j, 11), Cells(j, 15)).Interior.Color = RGB(255, 230, 255)

End If

Answer 2

Anonymous

こんにちは。

まず表の書き方を少し変えることで、計算しやすくなります。

下記のようにしてみてください。

0 件のコメント

次の方法で共有

VBAを使っての最大値の求め方を教えて下さい

2 件の追加の回答