2つの群の2値の平均値が最小となる・・の続き

質問

こにちは！
何故か見慣れない書式になって混乱しています。

ほんの数日前にここで「２つの群の２値の平均値が最小となる組みあわせ」という表題で質問して、見事に解決していただいて早速実務で使用し始めて一発で最適値が見つかって感動しています。
今後ず～と助かります。

さて、実は同様の作業があって、
目的は前回と同様なのですが、今回は２つの群（男女）の特性値Aの２値の平均が極力近いデータの組み合わせを探したいのです。

添付の表の値はダミーですが、
＜男のNo4とNo8の平均値と女のNo20とNo27の平均値が一番近い＞、というような組み合わせです。

1．解は複数あっても1つの組み合わせでOK。
2．解は組み合わせのデータNoのみでOK。
3．シートの任意の場所に結果を表示させたい（面倒なら無視でOK）。
実際の計算表に結果が表示されるようにしたいので解答の表示セル数は少ない方が良い。
結果の組み合わせの生データを計算表にC&Pするので，男列に2つ、女列に2つとか。

前回ご回答者様全員に補足説明が必要＝2回以上の回答となった経緯から、しばらくしてほとぼりが冷めてからの第2弾にしようと思っていたのですが、時間をおかない方が今回のご回答者の質問内容の理解が得やすいと思い厚かましく続けて質問させていただきます。

２値のケースが気持ち良く、特性値1つのケースで自作の表での馴れている作業とはいえ試行錯誤が嫌になってしまいましたので、繰り上げ??質問です。

回答No.4

kkkkkm · ベストアンサー

> 難しくなければ、男女のデータ数が最大20個で空白セルを無視、あるいは指定出来るように改良をお願いします。

B列とE列のそれぞれ最終行まで対象にします。
B列とE列は男と女のデータより下にデータがなく(上詰め)、途中空白の無い連続したデータであるという状態を想定しています。

たとえば以下のような状態です。
B列 E列
0.042 0.144
0.866 0.2
0.501
0.113
0.983
0.804
0.286

なお　No3をご利用の場合でも
For j = LBound(mASum) To UBound(mASum) - 1
For k = j + 1 To UBound(mBSum)

は

For j = LBound(mASum) To UBound(mASum)
For k = LBound(mBSum) To UBound(mBSum)

に変更してください。前者は全て比較できていなかったので。

> 今の方法は次回はやる気なくなっています。

これはコードの変更(訂正)はしないでという事でしょうか？

Sub Test2()
Dim mAddressA1() As String, mAddressA2() As String, mAddressB1() As String, mAddressB2() As String
Dim mASum() As Single, mBSum() As Single
Dim tmp As Single, tmpA As Single
Dim j As Long, k As Long, LastA As Long, LastB As Long
Dim LastRowA As Long, LastRowB As Long

LastRowA = Cells(Rows.Count, "B").End(xlUp).Row
LastRowB = Cells(Rows.Count, "E").End(xlUp).Row
Call mCombination(Cells(3, "B"), Cells(LastRowA, "B"), mASum, mAddressA1, mAddressA2)
Call mCombination(Cells(3, "E"), Cells(LastRowB, "E"), mBSum, mAddressB1, mAddressB2)

tmp = 100
For j = LBound(mASum) To UBound(mASum)
For k = LBound(mBSum) To UBound(mBSum)
tmpA = Abs(mASum(j) - mBSum(k))
If tmpA < tmp Then
tmp = tmpA
LastA = j
LastB = k
End If
Next
Next

Range("H1").Value = "男"
Range("H2").Value = Range(mAddressA1(LastA)).Value
Range("H3").Value = Range(mAddressA2(LastA)).Value
Range("H4").Formula = "=AVERAGE(H2,H3)"
Range("I1").Value = "女"
Range("I2").Value = Range(mAddressB1(LastB)).Value
Range("I3").Value = Range(mAddressB2(LastB)).Value
Range("I4").Formula = "=AVERAGE(I2,I3)"

Range(mAddressA1(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressA2(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB1(LastB)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB2(LastB)).Offset(0, -1).Interior.Color = vbGreen
MsgBox "完了"
End Sub

Function mCombination(ByRef sRange As Range, ByRef eRange As Range, ByRef mSum() As Single, _
ByRef mAddress1() As String, ByRef mAddress2() As String)
Dim c As Range, d As Range
Dim i As Long
i = 0
For Each c In Range(sRange, eRange.Offset(-1, 0))
For Each d In Range(c.Offset(1, 0), eRange)
ReDim Preserve mSum(i)
ReDim Preserve mAddress1(i)
ReDim Preserve mAddress2(i)
mSum(i) = c.Value + d.Value
mAddress1(i) = c.Address
mAddress2(i) = d.Address
i = i + 1
Next
Next
End Function

お礼

もし夕方までお忙しいようなら午後にはBSにして閉め切ろうかと思って見てみたら、またまた、早すぎるご回答でビックリしていますが、大感謝！！の2乗です。

> 今の方法は次回はやる気なくなっています。
は＃No3ですで解決（出来すぎレベル）で、
＜今の方法＞というのは自作の表に書式設定で着色されたセル（候補）の計算式への当てはめ作業、名付けて＜試行錯誤法＞のことです。

これも言葉足らずで少しでも気分を害されたならお詫びします。

私にはすでに＃No3がありますので約束通りこれで一旦決め切らせてもらいます。（これ以上のお手数は不要で、もったいない）

尚、蛇足ですが
セルに着色できたことから回答の数字は不要で、更にMsgBoxの「完了」も着色で分かることから昨夜削除してみて問題なく動くこと確認しました。

うまく行けば今使用しているBookにこのマクロをコピペしたらそのまま完璧（知らない人でも生データ入力後マクロボタンのワンクリック）で数値が出るように出来そうです。（私の実力でも）

これは前回の2値のケースの解決と合わせてすごいことです!！
どの位すごいかは数年前に退職した前任者に見せてあげたいくらいすごいことです。
長くなるので止めます。

本当に今回も見放さずに徹底的なお付き合いに深謝いたします。

チームメンバー 一同より

回答No.3

kkkkkm

> 前回の質問の不手際についてはご容赦願います。

いえ、私のt理解力のなさで何度も質問してすみません。

> 女の平均値が男の下に出て、女の平均値が空白ですが、

これはNo2の訂正でお願いした部分です。コードをコピペしたときに変更し忘れたものです。

No1でよろしければ
同じような操作がある部分(For Each～Nextの部分)を一つにしました。
以後訂正する部分が同じ操作のところだと元だと2か所訂正するのが一か所ですみます。

Sub Test2()
Dim mAddressA1() As String, mAddressA2() As String, mAddressB1() As String, mAddressB2() As String
Dim mASum() As Single, mBSum() As Single
Dim tmp As Single, tmpA As Single
Dim j As Long, k As Long, LastA As Long, LastB As Long

Call mCombination(Cells(3, "B"), Cells(17, "B"), mASum, mAddressA1, mAddressA2)
Call mCombination(Cells(3, "E"), Cells(17, "E"), mBSum, mAddressB1, mAddressB2)

tmp = 100
For j = LBound(mASum) To UBound(mASum) - 1
For k = j + 1 To UBound(mBSum)
tmpA = Abs(mASum(j) - mBSum(k))
If tmpA < tmp Then
tmp = tmpA
LastA = j
LastB = k
End If
Next
Next

Range("H1").Value = "男"
Range("H2").Value = Range(mAddressA1(LastA)).Value
Range("H3").Value = Range(mAddressA2(LastA)).Value
Range("H4").Formula = "=AVERAGE(H2,H3)"
Range("I1").Value = "女"
Range("I2").Value = Range(mAddressB1(LastB)).Value
Range("I3").Value = Range(mAddressB2(LastB)).Value
Range("I4").Formula = "=AVERAGE(I2,I3)"

Range(mAddressA1(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressA2(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB1(LastB)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB2(LastB)).Offset(0, -1).Interior.Color = vbGreen
MsgBox "完了"
End Sub

Function mCombination(ByRef sRange As Range, ByRef eRange As Range, ByRef mSum() As Single, _
ByRef mAddress1() As String, ByRef mAddress2() As String)
Dim c As Range, d As Range
Dim i As Long
i = 0
For Each c In Range(sRange, eRange.Offset(-1, 0))
For Each d In Range(c.Offset(1, 0), eRange)
ReDim Preserve mSum(i)
ReDim Preserve mAddress1(i)
ReDim Preserve mAddress2(i)
mSum(i) = c.Value + d.Value
mAddress1(i) = c.Address
mAddress2(i) = d.Address
i = i + 1
Next
Next
End Function

お礼

昨夜やってみた結果報告です。

実際の表に当てはめてみて、着色セルも生データにつくように出来ました。

1つごまかしたのは、対象データ（列）の下のセルには計算式が入っているのでこれをうまく回避出来なかったので、男列の下のセルには計算式の参照セルが空白の時には1、女列は２が入るようにしたら解答の対象外になるのでこれでいけそうです。

本日より担当者に説明して試用開始します。

報告まで。

回答No.2

kkkkkm

No1の訂正

Debug.Print LBound(mASum); UBound(mASum)

は不要で

For k = j + 1 To UBound(mASum)
は
For k = j + 1 To UBound(mBSum)

に(どちらも同じ行数なのでmASumでもいいと思いますが一応)

Range("H4").Formula = "=AVERAGE(I2,I3)"

は

Range("I4").Formula = "=AVERAGE(I2,I3)"

でした。

補足

こんばんわ。
ご対応が早すぎて当方の対応が間に合わなくて余計なお手数をおかけし申し訳なく。

自宅なのでダミーデータで＃No3を試してみて改善を確認しました。

実際の表を想定して1つ抜けている条件がありました。
抜けというより想定されていたのですが質問、回答とも複雑なりそうなので遠慮しました。

実際は、女のデータは15個ない場合がほとんどです。
つまり、組み合わせが見つかった時点で完了するので、実際には男、女のデータが2個づつあれば良いことになります。

男（標品）のデータは女（製品）のデータの受け側で事前に15回試験して準備しておくようにしています。
よって女データは最低2個です。この2個の平均値が規格範囲の誤差で男データで見つかれば完了。

A,Bの2成分系の質問時には、もし空白セルが選択されたら10とか100とか桁違いの値で埋めれば良いと考えてました。

がここまで出来ると欲が出てきて、難しくなければ、男女のデータ数が最大20個で空白セルを無視、あるいは指定出来るように改良をお願いします。
No3のコードの骨子が変わるような改良ならNo3で十分（過ぎる）レベルですのでいじらないでください。
1回のみのトライでお願いします。

今の方法は次回はやる気なくなっています。

回答No.1

kkkkkm

> ２つの群（男女）の特性値Aの２値の平均が極力近いデータの組み合わせ

男3と6、女22と28で平均の差ほぼ0だと思うのですが・・・

違うかもしれないのでコードは素のままというか練っていません。

Sub Test()
Dim c As Range, d As Range
Dim mAddressA1() As String, mAddressA2() As String, mAddressB1() As String, mAddressB2() As String
Dim mASum() As Single, mBSum() As Single
Dim tmp As Single, tmpA As Single
Dim i As Long, j As Long, k As Long, LastA As Long, LastB As Long

i = 0
For Each c In Range(Cells(3, "B"), Cells(16, "B"))
For Each d In Range(c.Offset(1, 0), Cells(17, "B"))
ReDim Preserve mASum(i)
ReDim Preserve mAddressA1(i)
ReDim Preserve mAddressA2(i)
mASum(i) = c.Value + d.Value
mAddressA1(i) = c.Address
mAddressA2(i) = d.Address
i = i + 1
Next
Next
i = 0
For Each c In Range(Cells(3, "E"), Cells(16, "E"))
For Each d In Range(c.Offset(1, 0), Cells(17, "E"))
ReDim Preserve mBSum(i)
ReDim Preserve mAddressB1(i)
ReDim Preserve mAddressB2(i)
mBSum(i) = c.Value + d.Value
mAddressB1(i) = c.Address
mAddressB2(i) = d.Address
i = i + 1
Next
Next
tmp = 100
Debug.Print LBound(mASum); UBound(mASum)
For j = LBound(mASum) To UBound(mASum) - 1
For k = j + 1 To UBound(mASum)
tmpA = Abs(mASum(j) - mBSum(k))
If tmpA < tmp Then
tmp = tmpA
LastA = j
LastB = k
End If
Next
Next

Range("H1").Value = "男"
Range("H2").Value = Range(mAddressA1(LastA)).Value
Range("H3").Value = Range(mAddressA2(LastA)).Value
Range("H4").Formula = "=AVERAGE(H2,H3)"
Range("I1").Value = "女"
Range("I2").Value = Range(mAddressB1(LastB)).Value
Range("I3").Value = Range(mAddressB2(LastB)).Value
Range("H4").Formula = "=AVERAGE(I2,I3)"

Range(mAddressA1(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressA2(LastA)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB1(LastB)).Offset(0, -1).Interior.Color = vbGreen
Range(mAddressB2(LastB)).Offset(0, -1).Interior.Color = vbGreen
MsgBox "完了"
End Sub

お礼

いつもお世話になっております。
早々のご回答感謝。

早速やってみました。
一発で出来ました！
しかも遠慮した着色まで！！

結果が確認しやすいのでこれでいけると思います。
明日中に実際の表でいくつか確認して報告させていただきます。
やはり直ぐの追加質問で良かった（と思いました）。
本当に何度もありがとうございます。

前回の質問の不手際についてはご容赦願います。

========＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
女の平均値が男の下に出て、女の平均値が空白ですが、
ご愛敬で全く問題なし。
（当方でも修正可能だと思いますしでなくても問題なし）
========＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝