[[20180424173356]]　『組み合わせの抽出』（運慶）　ページの最後に飛ぶ

『組み合わせの抽出』（運慶）

VBAでロジックを考えています。
与えられたデータの1行目の値を超える最小値となる組み合わせを抽出用データから
抽出したいのですが、ロジックが思いつきません。なにかいい方法ないでしょうか？

与えられたデータの2行目以降は抽出対象メンバーです。
下記の例ですと与えられたデータの「20」を超え、なおかつ最小のメンバーの
組み合わせ1,2,3,5で21を抽出したいです。
与えられたデータ内のメンバーは最低1回は出てこないといけません。
組み合わせが複数見つかった場合は1パターンだけでOKです。

【与えられたデータ】
20
Aさん
Bさん
Cさん

【抽出用データ】
1.Aさん　5
2.Bさん　6
3.Bさん　8
4.Aさん　44
5.Cさん　2
6.Dさん　3

【結果】
1.Aさん　5
2.Bさん　6
3.Bさん　8
5.Cさん　2

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 考え方は分かりましたが、抽出用のデータは実際に何個くらいあるんですか？

 こういう問題は、結局、しらみ潰しにならざるを得ないので、何個あるかは凄く重要なんですけど。

（半平太） 2018/04/24(火) 22:11

半平太様ありがとうございます。
抽出用データは状況によりまちまちなんですが50～300件ほどあります。
（運慶） 2018/04/25(水) 08:19

 ＞結局、しらみ潰しにならざるを得ないので、

 と書いたんですが、そうでもなかったです。　m(__)m

 単に各メンバーの最低値をひとつずつ決めたあと、
 残り全部を昇順に並べれば、どこで合計最低値になるか直ぐ分かりますよね？

 <考え方>
  行  ____A___  _B_  _C_  __D__  _E_  _____F_____  _G_ 
   1 【抽出用】  値               値               累計                        
   2  Aさん       5       Aさん    5  同人の最小     5                     
   3  Bさん       6       Bさん    6  同人の最小    11                     
   4  Bさん       8       Cさん    2  同人の最小    13  ←最低一回の条件をクリアする地点 
   5  Aさん      44       Bさん    8  残り昇順      21  ←ここが目標以上の地点なので、上から4つを抽出する
   6  Cさん       2       Aさん   44  残り昇順      65                     
   7  Dさん       3

 こんなロジックでよければ、あっという間に計算できますが、
 本当にそんなロジックでいいんですかねぇ・・・

 他に条件があるんじゃないですか？

（半平太） 2018/04/25(水) 10:33

なるほどなるほど。
納得しました。
今のところほかに条件はないので教えていただいた
ロジックで試してみます。
ありがとうございました！
（運慶） 2018/04/25(水) 11:51

以下のようなパターンは無いんですか？

【与えられたデータ】
20
Aさん
Bさん
Cさん
【抽出用データ】
1.Aさん　5
2.Bさん　6
3.Bさん　8
4.Aさん　44
5.Cさん　7
6.Dさん　3
【結果】
1.Aさん　5
3.Bさん　8
5.Cさん　7

（sy） 2018/04/25(水) 12:31

 ごめんなさい、私のロジックは間違っていました。m(__)m

 最小値を先に決めると、後の選択に悪い影響が出ます。

 下図において、基準値が15とすると（目標はそれを超えるので「16以上」となる）、

 当初のアイデアでは、合計最小値は「27」になりますが・・・

  行  ________A________  _B_  _C_  __D__  _E_  _____F_____  _G_
   1  【抽出用データ】                                         
   2  Aさん                1       Aさん    1  同人の最小     1
   3  Aさん                1       Bさん   10  同人の最小    11
   4  Aさん                1       Aさん    1  残り昇順      12
   5  Aさん                1       Aさん    1  残り昇順      13
   6  Bさん               10       Aさん    1  残り昇順      14
   7  Bさん               13       Bさん   13  残り昇順      27　←ここまで膨らむ
   8  Bさん               30       Bさん   30  残り昇順      57
   9

 例えば、Bさんの13を最初に決めれば、「16」で済みます

  10  上と同じ                                                 
  11  Aさん                1       Aさん    1  同人の最小     1
  12  Aさん                1       Bさん   13  同人の2番目   14
  13  Aさん                1       Aさん    1  残り昇順      15
  14  Aさん                1       Aさん    1  残り昇順      16　←ここで済む
  15  Bさん               10       Aさん    1  残り昇順      17
  16  Bさん               13       Bさん   10  残り昇順      27
  17  Bさん               30       Bさん   30  残り昇順      57

（半平太） 2018/04/25(水) 12:32

 またまた間違えたので、ここに書いたのを削除します。

（半平太） 2018/04/25(水) 17:19

遅くなりましてすみません。

sy様ありがとうございます。
ご提示いただいたようなパターンも存在します。

半平太様ありがとうございます。
確かに最小値を先に取得してしまうとダメな場合もありました。

基準値が20の場合、各人から1つずつの値を取得し、
その合計が21ちょうどになる場合はその組み合わせを採用すれば
いいかとは思っています。
その組み合わせが見つからない場合・・・の組み合わせの決定の
やり方がやはりわからないです。

全パターン合計するのは途方もない組み合わせ数になってしまいますので
できれば避けたいです。

条件というわけではないのですが、ひとつ失念していたことがありまして、
実際には基準値の20というのは抽出用データの全合計の10％の切り捨て数字です。
（抽出用データの合計値が209ならその10％の切り捨て数字20が基準値となります）

（運慶） 2018/04/26(木) 08:36

 ＞条件というわけではないのですが、ひとつ失念していたことがありまして、 
 ＞実際には基準値の20というのは抽出用データの全合計の10％の切り捨て数字です。 
 ＞（抽出用データの合計値が209ならその10％の切り捨て数字20が基準値となります）

 ・・と言うことは、組合せ数が多くて大変と思える反面、
 ピッタリ目標値になる組合せが沢山存在する確率もかなり高い様な気がします。

 実際のサンプルデータを提示いただけないですか？
 （抽出候補99件、与えられたデータも実物で、名前は仮名で-氏名01、氏名02・・・氏名99）

 あと、解は１つあればいいので、ソルバーが使えないかなぁ、なんて思っているんですけども。

（半平太） 2018/04/26(木) 09:38

半平太様ありがとうございます。
実際のデータとなります。
0のデータもありますが、こちらは無視でOKです。
合計が2305となりますので抽出したいのは230超の最小値です。
ここでは氏名01,02,04,05から抽出したいです。

氏名01 21
氏名01 25
氏名01 17
氏名01 30
氏名01 6
氏名01 36
氏名01 31
氏名01 21
氏名02 11
氏名02 41
氏名02 23
氏名02 58
氏名02 48
氏名03 31
氏名03 20
氏名03 52
氏名03 39
氏名01 1
氏名01 25
氏名01 26
氏名01 16
氏名01 8
氏名01 25
氏名01 29
氏名01 48
氏名01 22
氏名01 7
氏名04 24
氏名04 60
氏名04 63
氏名04 27
氏名04 50
氏名05 34
氏名06 6
氏名05 11
氏名05 23
氏名05 16
氏名05 13
氏名04 40
氏名05 26
氏名05 1
氏名05 39
氏名05 45
氏名05 25
氏名01 24
氏名01 14
氏名01 28
氏名01 15
氏名01 33
氏名07 52
氏名07 79
氏名07 35
氏名07 59
氏名07 67
氏名01 14
氏名01 25
氏名02 68
氏名08 66
氏名06 3
氏名06 9
氏名06 34
氏名06 27
氏名06 40
氏名06 19
氏名06 34
氏名08 62
氏名03 7
氏名03 1
氏名03 1
氏名03 10
氏名03 12
氏名03 6
氏名03 4
氏名03 13
氏名03 6
氏名03 6
氏名03 1
氏名03 14
氏名03 12
氏名03 25
氏名03 5
氏名02 2
氏名02 5
氏名02 9
氏名02 12
氏名02 17
氏名02 2
氏名02 10
氏名02 7
氏名02 13
氏名02 15
氏名02 19
氏名02 9
氏名02 6
氏名02 15
氏名02 14
氏名02 0
氏名02 0

（運慶） 2018/04/26(木) 10:17

数字を並べ変えてから、総当たりで試すコードを書いてみたところ、以下の解が得られました。

氏名01 48
氏名02 48
氏名04 40
氏名04 50
氏名05 45

しかし、例えば全部偶数のように、目標値+1 にはならない条件等で総当たりの最後まで回ってしまう場合、結果が出るまで何年かかるか判りません。（最大、2^300回ですよね？）

別案ですが、総当たりせず、ランダムに割り当てて、一番良かったものを採用、というコードならば、常にある程度の時間はかかりますし、毎回答えが違ってきますし、本当にぎりぎりな線ではない答えになる可能性大ですが、何年も待つような事は無くなります。そういうコードを考えてみてはいかがでしょうか？
（???） 2018/04/26(木) 15:13

？？？様ありがとうございます。
総当たりは端から敬遠してしまっていました。
別案でいただいた「ランダムに割り当てて～」というところ、
ちょっとイメージがわかないのですが、コードをご提示いただくことって
可能でしょうか？
（併せて総当たりのコードもご提示いただけましたら参考になります。）

現在も格闘しておりまして、なかなか進まない状況です。
（運慶） 2018/04/26(木) 17:09

参考までに総当たり版を書いておきますが、条件が悪いと一生回し続けても結果が出ないものですよ？使い物にならなそうですが…。

ランダム案は、コーディングするには私だってゼロから書かなければいけないのだし、そこはアイデアだけでご勘弁を。総当たり案の cPt 部分をランダムに決める…、と考えれば、イメージできるでしょうか。

 Sub test()
    Dim AR1 As Object
    Dim AR2 As Object
    Dim wkT As Worksheet
    Dim wkA As Worksheet
    Dim wkK As Worksheet
    Dim wkW As Worksheet
    Dim cPt As String
    Dim cw() As String
    Dim iw() As Long
    Dim cOK As String
    Dim iOK As Long
    Dim i As Long
    Dim iR As Long
    Dim iMax As Long
    Dim iTarget As Long
    Dim iAll As Long

    Application.DisplayAlerts = False

    Set AR1 = CreateObject("System.Collections.ArrayList")
    Set AR2 = CreateObject("System.Collections.ArrayList")
    Set wkT = Sheets("抽出用データ")
    Set wkA = Sheets("与えられたデータ")
    Set wkK = Sheets("結果")

    iTarget = wkA.Range("A1")
    For i = 2 To wkA.Cells(wkA.Rows.Count, "A").End(xlUp).Row
        AR1.Add wkA.Cells(i, "A").Value
    Next i

    wkK.Cells.Delete
    wkT.Copy after:=Sheets(Sheets.Count)
    Set wkW = Sheets(Sheets.Count)

    With wkW
        With .Sort
            .SortFields.Add Key:=wkW.Range("B:B"), Order:=xlAscending
            .SortFields.Add Key:=wkW.Range("A:A"), Order:=xlAscending
            .SetRange wkW.Range("A:B")
            .Header = xlNo
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
            If .Cells(i, "B").Value = 0 Or AR1.Contains(.Cells(i, "A").Value) = False Then
                .Rows(i).Delete
            End If
        Next i

        iMax = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim cw(iMax)
        ReDim iw(iMax)
        For i = 1 To iMax
            cw(i) = .Cells(i, "A").Value
            iw(i) = .Cells(i, "B").Value
        Next i
    End With

    iOK = 999999999
    cPt = String(iMax, "0")
    Do While cPt <> String(iMax, "1")
        If Mid(cPt, iMax, 1) = "0" Then
            Mid(cPt, iMax, 1) = "1"
        Else
            Mid(cPt, iMax, 1) = "0"
            Mid(cPt, iMax - 1, 1) = CStr(Val(Mid(cPt, iMax - 1, 1)) Mod 2 + 1)
        End If
        For i = iMax To 1 Step -1
            If Mid(cPt, i, 1) = "2" Then
                Mid(cPt, i, 1) = "0"
                Mid(cPt, i - 1, 1) = CStr(Val(Mid(cPt, i - 1, 1)) Mod 2 + 1)
            End If
        Next i
        Application.StatusBar = cPt
        DoEvents

        iAll = 0
        For i = 1 To iMax
            If Mid(cPt, i, 1) = "1" Then
                iAll = iAll + iw(i)
            End If
        Next i
        If iAll < iOK Then
            AR2.Clear
            For i = 1 To iMax
                If Mid(cPt, i, 1) = "1" Then
                    If Not AR2.Contains(cw(i)) Then
                        AR2.Add cw(i)
                    End If
                End If
            Next i
            If AR1.Count = AR2.Count Then
                If iTarget < iAll Then
                    iOK = iAll
                    cOK = cPt
                    If iTarget + 1 = iAll Then
                        Exit Do
                    End If
                End If
            End If
        End If
    Loop

    If cOK = "" Then
        MsgBox "見つかりませんでした。", vbCritical
    Else
        With wkK
            For i = 1 To iMax
                If Mid(cOK, i, 1) = "1" Then
                    iR = iR + 1
                    .Cells(iR, "A").Value = cw(i)
                    .Cells(iR, "B").Value = iw(i)
                End If
            Next i
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=wkK.Range("A:A"), Order:=xlAscending
                .SetRange wkK.Range("A:B")
                .Header = xlNo
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
        MsgBox "終了", vbInformation
    End If

    wkW.Delete
    Application.DisplayAlerts = True
    Application.StatusBar = ""
 End Sub
（???） 2018/04/26(木) 17:20

 本当に３、４人程度だったんですね。

 データに「変なクセ」が無さそうなので、現実問題としては楽勝だと思います。
 目標ピッタリの組合せが相当有りそうなので、あっという間に解に辿り着けると思います。

 <ロジック>
 １．各候補にランダムに一つずつ割り振る

 ２．残りをランダムに選んで目標に達するまで追加する
     ただし、残りの中に、不足額とピッタリ合致するものがあったら、それを優先採用する。

 ３．累計が目標より１つでも多くなったら、上記１に戻って、ピッタリな解が得られるまで繰り返す。

 実際、そんな、ロジックで作ってみると、殆んど1回で終わります。
 念の為、2回トライする様に作ってあります。

 もし、他のデータセットで、2回やってもダメな時が「頻発」するなら、
 また質問してください。(その時は、その実例を添えてください）

 <Sheet1 実行前>　　　　　　　　　　　　　　　　　　<Sheet1 実行後>
  行  ___A___  _B_  _C_  _D_  _E_  _F_  ___G___      行  ___A___  _B_  _C_  ___D___  _E_  _F_  ___G___
   1  氏名01    21                         230        1  氏名01    21       氏名01    31          230 
   2  氏名01    25                      氏名01        2  氏名01    25       氏名02    68       氏名01 
   3  氏名01    17                      氏名02        3  氏名01    17       氏名04    60       氏名02 
   4  氏名01    30                      氏名04        4  氏名01    30       氏名05    23       氏名04 
   5  氏名01     6                      氏名05        5  氏名01     6       氏名01    30       氏名05 
   6  氏名01    36                                    6  氏名01    36       氏名06    19              
   7  氏名01    31                                    7  氏名01    31

 Sub Main()
     Dim Wsh As Worksheet
     Dim NN As Long
     Dim numOfData As Long
     Dim namesOfEssential
     Dim EssName
     Dim RdmAry
     Dim ValName
     Dim ValVer
     Dim numChosen As Long
     Dim Selected()
     Dim Ruikei As Long
     Dim Tgt As Long
     Dim LeftToGo As Long
     Dim Pos
     Dim Fenito As Boolean '終了フラグ
     Dim Tried As Long  'トライ回数

     Set Wsh = Sheets("Sheet1")
     Tgt = Wsh.Range("G1").Value + 1

     numOfData = Wsh.Cells(10000, "A").End(xlUp).Row

     Do
         ReDim Selected(1 To numOfData, 1 To 2)
 　　    Randomize
         Ruikei = 0
         Tried = Tried + 1
         numChosen = 0 '初期化
         RdmAry = RndAry(numOfData)

         '先に必ず選択すべき候補の数値を選らぶ
         namesOfEssential = Wsh.Range("G2", Wsh.Cells(10000, "G").End(xlUp)).Value
         ValName = Wsh.Range("A1", Wsh.Cells(10000, "A").End(xlUp)).Value
         ValVer = Wsh.Range("B1", Wsh.Cells(10000, "B").End(xlUp)).Value

         For Each EssName In namesOfEssential
             For NN = 1 To numOfData
                 If ValName(RdmAry(NN), 1) = EssName Then
                     If ValVer(RdmAry(NN), 1) > 0 Then
                         numChosen = numChosen + 1
                         Selected(numChosen, 1) = EssName
                         Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                         Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                         ValVer(RdmAry(NN), 1) = 0
                         Exit For
                     End If
                 End If
             Next
         Next

         NN = 0
         Do
             LeftToGo = Tgt - Ruikei 'あと幾ら必要かチェックする
             If LeftToGo = 0 Then
                 'ピッタリ→終了
                 Fenito = True
                 Exit Do
             ElseIf LeftToGo < 0 Then
                 'ピッタリにならない→やり直し
                 Exit Do
             Else
                 'ピッタリ必要な数値があるかチェックする
                 Pos = Application.Match(LeftToGo, ValVer, 0)
                 If IsNumeric(Pos) Then '最後を発見
                     numChosen = numChosen + 1
                     Selected(numChosen, 1) = ValName(Pos, 1)
                     Selected(numChosen, 2) = ValVer(Pos, 1)
                     Ruikei = Ruikei + ValVer(Pos, 1)
                     ValVer(Pos, 1) = 0
                     Fenito = True
                     Exit Do
                 End If

                 NN = NN + 1

                 If ValVer(RdmAry(NN), 1) > 0 Then
                     numChosen = numChosen + 1
                     Selected(numChosen, 1) = ValName(RdmAry(NN), 1)
                     Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                     Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                     ValVer(RdmAry(NN), 1) = 0
                 End If
             End If
         Loop

     Loop Until Fenito Or Tried >= 2

     Wsh.Range("D1:E10000").ClearContents

     If Fenito = False And Tried >= 2 Then
         MsgBox "2回トライしましたが発見できませんでした。再トライしてください"
         Debug.Print Tried
         Exit Sub
     End If
     Debug.Print Tried
     Wsh.Range("D1").Resize(numChosen, 2).Value = Selected
 End Sub

 Private Function RndAry(ByVal 総数 As Long)
     Dim i As Long
     Dim numInOrder
     Dim rndInOrder

     ReDim numInOrder(1 To 総数)
     ReDim rawrnd(1 To 総数)

     For i = 1 To 総数
         numInOrder(i) = i
         rawrnd(i) = Rnd()
     Next i

     rndInOrder = Application.Small(rawrnd, numInOrder)
     RndAry = Application.Match(rawrnd, rndInOrder, 0)

 End Function

（半平太） 2018/04/26(木) 20:31

 半平太さんから、完璧な回答が出てるので今更なんですが、
 ご提示のようなデータなら、以下のようなコードでも出来そうな気がします。

 ただ私のは乱数を使ってないので、出来ない時は「そのデータ」「その条件」では使えません。

 レイアウトはA・B列に抽出用データ　
 D1 =INT(SUM(B:B)/10)
 D2以下に条件、
 I1セルを作業セルに使用して、
 F・G列に結果を表示します。

    |[A]   |[B]|[C]|[D]   |[E]|[F]   |[G]|[H]|[I]
 [1]|氏名01| 21|   |   230|   |氏名01| 48|   |  0
 [2]|氏名01| 25|   |氏名01|   |氏名02| 68|   |   
 [3]|氏名01| 17|   |氏名02|   |氏名04| 63|   |   
 [4]|氏名01| 30|   |氏名04|   |氏名05| 45|   |   
 [5]|氏名01|  6|   |氏名05|   |氏名01|  7|   |   
 [6]|氏名01| 36|   |      |   |      |   |   |   
 [7]|氏名01| 31|   |      |   |      |   |   |

 Sub test()
    Const shName As String = "マクロ検索"  '←シート名、適切な名前に変更して下さい

    Dim sh As Worksheet
    Dim r As Range
    Dim i As Long

    Set sh = Sheets(shName)
    sh.Range("F:G").ClearContents
    sh.Range("D1").CurrentRegion.Offset(1).Copy sh.Range("F1")
    sh.Range("F1").CurrentRegion.Offset(1, 1).Formula = _
            "=IF(F2="""","""",IFERROR(AGGREGATE(14,6,1/((A$1:A$500=F2)*(B$1:B$500<D$1-SUM(G$1:G1)+1))*B$1:B$500,1)" _
            & ",AGGREGATE(15,6,1/(A$1:A$500=F2)*B$1:B$500,1)))"
    sh.Range("G1").Formula = "=AGGREGATE(14,6,1/(A$1:A$500=F1)*B$1:B$500,1)"
    With sh.Range("F1").CurrentRegion
        .Value = .Value
    End With
    sh.Range("I1").Formula = "=D1-SUM(G:G)+1"
    If sh.Range("I1").Value = 0 Then Exit Sub

    If sh.Range("I1").Value < 0 Then
        For i = 1 To sh.Range("G" & Rows.Count).End(xlUp).Row
            If sh.Range("G" & i).Value <= -sh.Range("I1").Value Then
                With sh.Range("G" & i)
                    .FormulaR1C1 = "=AGGREGATE(15,6,1/(R1C1:R500C1=RC6)*R1C2:R500C2,1)"
                    .Value = .Value
                End With
            Else
                sh.Range("G" & i).Value = Range("G" & i).Value + sh.Range("I1").Value
                If WorksheetFunction.CountIfs(sh.Range("A:A"), sh.Range("F" & i), sh.Range("B:B"), sh.Range("G" & i)) Then
                    Exit Sub
                Else
                    With sh.Range("G" & i)
                        .Formula = "=IFERROR(AGGREGATE(14,6,1/((A1:A500=F2)*(B1:B500<" & sh.Range("G" & i).Value & "))*B1:B500,1)" _
                                & ",AGGREGATE(15,6,1/((A1:A500=F2)*(B1:B500>" & sh.Range("G" & i).Value & "))*B1:B500,1))"
                        .Value = .Value
                        If sh.Range("I1").Value > 0 Then Exit For
                    End With
                End If
            End If
        Next i
    End If

    Set r = sh.Range("B:B").Find(What:=sh.Range("D1").Value - WorksheetFunction.Sum(sh.Range("G:G")) + 1, LookAt:=xlWhole)
    sh.Range("F1").End(xlDown).Offset(1).Resize(, 2).Value = r.Offset(, -1).Resize(, 2).Value

 End Sub

（sy） 2018/04/26(木) 23:36

 こちらは別にお勧めはしませんが、お遊びで作ってみたので提示します。
 ご提示のデータで条件が5つまでの検索が出来る数式案です。

     |[A]   |[B]|[C]|[D]   |[E]|[F]   |[G]|[H]|[I]   |[J]   |[K]   |[L]   |[M]|[N]  |[O]|[P]   |[Q]   |[R]   |[S]   |[T]|[U]|[V]  
 [1]|氏名01| 21|   |   230|   |氏名01| 31|   |    25|    19|    10|     5|  1|23750|   |氏名01|氏名03|氏名05|氏名07|   |   |19955
 [2]|氏名01| 25|   |氏名01|   |氏名03| 52|   |氏名01|氏名03|氏名05|氏名07|   |     |   |    48|    52|    45|    79|   |224|   27
 [3]|氏名01| 17|   |氏名03|   |氏名05| 34|   |    48|    52|    45|    79|   |     |   |    36|    52|    45|    79|   |212|   64
 [4]|氏名01| 30|   |氏名05|   |氏名07| 35|   |    36|    39|    39|    67|   |     |   |    33|    52|    45|    79|   |209|   26
 [5]|氏名01|  6|   |氏名07|   |氏名07| 79|   |    33|    31|    34|    59|   |     |   |    31|    52|    45|    79|   |207|   28
 [6]|氏名01| 36|   |      |   |      |   |   |    31|    25|    26|    52|   |     |   |    30|    52|    45|    79|   |206|    2
 [7]|氏名01| 31|   |      |   |      |   |   |    30|    20|    25|    35|   |     |   |    29|    52|    45|    79|   |205|   20

 A・B列、抽出用データ

 D1 =INT(SUM(B:B)/10)
 D2以下、条件

 F1 =IF(D2="",IF(D1="","",INDEX(A$1:A$500,INDEX(V$1:V$100000,V$1))),D2)
 G1 =IF(D2="",IF(D1="","",INDEX(B$1:B$500,INDEX(V$1:V$100000,V$1))),INDEX(P$1:T$100000,V$1,ROW(A1)))
 それぞれ6行目までフィルコピー

 I1 =MAX(COUNT(I3:I50),1)
 I2 =INDEX($D:$D,COLUMN(B1))&""
 それぞれM列までフィルコピー

 I3 =IFERROR(AGGREGATE(14,6,1/(($A$1:$A$500=I$2)*($B$1:$B$500>0))*$B$1:$B$500,ROW(A1)),"")
 M列と約50行くらいまでフィルコピー

 N1 =I1*J1*K1*L1*M1

 P1 =I2
 T列までフィルコピー

 P2 =IF(OR(Q$1="",ROW(A1)>N$1),"",INDEX(I$3:I$50,MOD(ROW(A1)-1,I$1)+1))
 Q2 =IF(OR(Q$1="",ROW(A1)>N$1),"",INDEX(J$3:J$50,INT(MOD(ROW(A1)-1,I$1*J$1)/I$1+1)))
 R2 =IF(OR(R$1="",ROW(A1)>N$1),"",INDEX(K$3:K$50,INT(MOD(ROW(A1)-1,I$1*J$1*K$1)/(I$1*J$1)+1)))
 S2 =IF(OR(S$1="",ROW(A1)>N$1),"",INDEX(L$3:L$50,INT(MOD(ROW(A1)-1,I$1*J$1*K$1*L$1)/(I$1*J$1*K$1)+1)))
 T2 =IF(OR(T$1="",ROW(A1)>N$1),"",INDEX(M$3:M$50,INT(MOD(ROW(A1)-1,I$1*J$1*K$1*L$1*M$1)/(I$1*J$1*K$1*L$1)+1)))
 U2 =IF(COUNT(P2:T2),SUM(P2:T2),"")
 V2 =IFERROR(MATCH(D$1-U2+1,B$1:B$500,0),"")
 それぞれ約10万行までフィルコピー

 V1 =IFERROR(MATCH(501,V2:V100000)+1,"")

（sy） 2018/04/26(木) 23:57

？？？様、半平太様、sy様ありがとうございます。
皆様から回答をたくさんいただき、やっとすすめられそうです。

sy様にご提示いただいたコードで試してみましたら、最下行でエラーが発生するケースが多かったです。。
変数rが見つからないようでした。
半平太様にご提示いただいたコードは完璧に動いています。

ひとつひとつロジックを確認させていただき、運用させていただきたいと思います。
私一人の考えじゃ到底及ばないものばかりでした。

ひとまずお礼まで。
（運慶） 2018/04/27(金) 09:02

半平太様すみません。
完璧に動いています、と書きましたが私の言葉が足りなかったようで
抽出対象外のメンバーを拾ってきていました。

少し加工させていただいて、抽出対象内のメンバーのみ拾うように
したのですがヒット率がぐっと落ちてしまいました。。

下記加工部分のみ抜粋

'ピッタリ必要な数値があるかチェックする

 Pos = Application.Match(LeftToGo, ValVer, 0)
 If IsNumeric(Pos) Then
    For Each EssName In namesOfEssential
        If ValName(Pos, 1) = EssName Then
            numChosen = numChosen + 1
            Selected(numChosen, 1) = ValName(Pos, 1)
            Selected(numChosen, 2) = ValVer(Pos, 1)
            Selected(numChosen, 3) = ValRow(Pos, 1)
            Ruikei = Ruikei + ValVer(Pos, 1)
            ValVer(Pos, 1) = 0
            Fenito = True
            Exit Do
      End If
    Next
 End If
 If NN + 1 > numOfData Then Fenito = False: Exit Do
 NN = NN + 1
 For Each EssName In namesOfEssential
    If ValName(RdmAry(NN), 1) = EssName Then
        If ValVer(RdmAry(NN), 1) > 0 Then
           numChosen = numChosen + 1
           Selected(numChosen, 1) = ValName(RdmAry(NN), 1)
           Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
           Selected(numChosen, 3) = ValRow(RdmAry(NN), 1)
           Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
           ValVer(RdmAry(NN), 1) = 0
        End If
    End If
Next

（運慶） 2018/04/27(金) 13:52

 あれ?　抽出候補1回以上で、当該候補群に限るんですか？

 それだと、ヒット率が落ちると思いますので、トライ限度を5回に引き上げておきますね。

 ロジックとしては、事前準備で候補以外は「0」にしてしまう(無視すべきデータに変える）。

 メインだけ以下に丸ごと差し替え

 Sub Main()
    Dim Wsh As Worksheet
    Dim NN As Long
    Dim numOfData As Long
    Dim namesOfEssential
    Dim EssName
    Dim RdmAry
    Dim ValName
    Dim ValVer
    Dim numChosen As Long
    Dim Selected()
    Dim Ruikei As Long
    Dim Tgt As Long
    Dim LeftToGo As Long
    Dim Pos
    Dim Fenito As Boolean '終了フラグ
    Dim Tried As Long  'トライ回数
    Dim RngEss As Range

    Set Wsh = Sheets("Sheet1")
    Tgt = Wsh.Range("G1").Value + 1

    numOfData = Wsh.Cells(10000, "A").End(xlUp).Row
    Set RngEss = Wsh.Range("G2", Wsh.Cells(10000, "G").End(xlUp))

    ValName = Wsh.Range("A1", Wsh.Cells(10000, "A").End(xlUp)).Value
    ValVer = Wsh.Range("B1", Wsh.Cells(10000, "B").End(xlUp)).Value

    '事前処理として、候補対象者じゃないものには0を埋める。
    For NN = 1 To numOfData
        If Application.CountIf(RngEss, ValName(NN, 1)) = 0 Then
            ValVer(NN, 1) = 0
        End If
    Next

    namesOfEssential = RngEss.Value

    Do
        ReDim Selected(1 To numOfData, 1 To 2)
        Randomize
        Ruikei = 0
        Tried = Tried + 1
        numChosen = 0 '初期化
        RdmAry = RndAry(numOfData)

        '先に必ず選択すべき候補の数値を選らぶ
        For Each EssName In namesOfEssential
            For NN = 1 To numOfData
                If ValName(RdmAry(NN), 1) = EssName Then
                    If ValVer(RdmAry(NN), 1) > 0 Then
                        numChosen = numChosen + 1
                        Selected(numChosen, 1) = EssName
                        Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                        Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                        ValVer(RdmAry(NN), 1) = 0
                        Exit For
                    End If
                End If
            Next
        Next

        NN = 0
        Do
            LeftToGo = Tgt - Ruikei 'あと幾ら必要かチェックする
            If LeftToGo = 0 Then
                'ピッタリ→終了
                Fenito = True
                Exit Do
            ElseIf LeftToGo < 0 Then
                'ピッタリにならない→やり直し
                Exit Do
            Else
                'ピッタリ必要な数値があるかチェックする
                Pos = Application.Match(LeftToGo, ValVer, 0)
                If IsNumeric(Pos) Then '最後を発見
                    numChosen = numChosen + 1
                    Selected(numChosen, 1) = ValName(Pos, 1)
                    Selected(numChosen, 2) = ValVer(Pos, 1)
                    Ruikei = Ruikei + ValVer(Pos, 1)
                    ValVer(Pos, 1) = 0
                    Fenito = True
                    Exit Do
                End If

                NN = NN + 1

                If ValVer(RdmAry(NN), 1) > 0 Then
                    numChosen = numChosen + 1
                    Selected(numChosen, 1) = ValName(RdmAry(NN), 1)
                    Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                    Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                    ValVer(RdmAry(NN), 1) = 0
                End If
            End If
        Loop

    Loop Until Fenito Or Tried >= 5 'トライ回数を5回とした場合
    Wsh.Range("D1:E10000").ClearContents

    If Fenito Then
        Debug.Print Tried
        Wsh.Range("D1").Resize(numChosen, 2).Value = Selected
    Else
        MsgBox Tried & "回トライしましたが発見できませんでした。再トライしてください"
        Exit Sub
    End If

 End Sub

（半平太） 2018/04/27(金) 14:41

 済みませーん。
 　Doの位置を　Valver = Wsh.Range(・・・　の上に持ってきてください。

 ＞    ValName = Wsh.Range("A1", Wsh.Cells(10000, "A").End(xlUp)).Value
 ＞    ValVer = Wsh.Range("B1", Wsh.Cells(10000, "B").End(xlUp)).Value
 ＞    
 ＞    '事前処理として、候補対象者じゃないものには0を埋める。
 ＞    For NN = 1 To numOfData
 ＞        If Application.CountIf(RngEss, ValName(NN, 1)) = 0 Then
 ＞            ValVer(NN, 1) = 0
 ＞        End If
 ＞    Next
 ＞    
 ＞    namesOfEssential = RngEss.Value
 ＞    
 ＞    Do

↓

     ValName = Wsh.Range("A1", Wsh.Cells(10000, "A").End(xlUp)).Value
   Do　　’←ここへ
     ValVer = Wsh.Range("B1", Wsh.Cells(10000, "B").End(xlUp)).Value

     '事前処理として、候補対象者じゃないものには0を埋める。
     For NN = 1 To numOfData
         If Application.CountIf(RngEss, ValName(NN, 1)) = 0 Then
             ValVer(NN, 1) = 0
         End If
     Next

     namesOfEssential = RngEss.Value

     ’←ここから

（半平太） 2018/04/27(金) 15:03

 やっつけ仕事で効率の悪いのを書いちゃったです。m(__)m

 上のは忘れてください。

 まだ、改善の余地ありますが、取りあえず、これで

  Sub Main()
     Dim Wsh As Worksheet
     Dim NN As Long
     Dim numOfData As Long
     Dim namesOfEssential
     Dim EssName
     Dim RdmAry
     Dim ValName
     Dim ValVer
     Dim ValOrg
     Dim numChosen As Long
     Dim Selected()
     Dim Ruikei As Long
     Dim Tgt As Long
     Dim LeftToGo As Long
     Dim Pos
     Dim Fenito As Boolean '終了フラグ
     Dim Tried As Long  'トライ回数
     Dim RngEss As Range

     Set Wsh = Sheets("Sheet1")
     Tgt = Wsh.Range("G1").Value + 1

     numOfData = Wsh.Cells(10000, "A").End(xlUp).Row
     Set RngEss = Wsh.Range("G2", Wsh.Cells(10000, "G").End(xlUp))

     ValName = Wsh.Range("A1", Wsh.Cells(10000, "A").End(xlUp)).Value
     ValOrg = Wsh.Range("B1", Wsh.Cells(10000, "B").End(xlUp)).Value

     '事前処理として、候補対象者じゃないものには0を埋める。
     For NN = 1 To numOfData
         If Application.CountIf(RngEss, ValName(NN, 1)) = 0 Then
             ValOrg(NN, 1) = 0
         End If
     Next

     namesOfEssential = RngEss.Value

     Do
         ReDim Selected(1 To numOfData, 1 To 2)
         Randomize
         Ruikei = 0
         Tried = Tried + 1
         numChosen = 0 '初期化
         RdmAry = RndAry(numOfData)
         ValVer = ValOrg

         '先に必ず選択すべき候補の数値を選らぶ
         For Each EssName In namesOfEssential
             For NN = 1 To numOfData
                 If ValName(RdmAry(NN), 1) = EssName Then
                     If ValVer(RdmAry(NN), 1) > 0 Then
                         numChosen = numChosen + 1
                         Selected(numChosen, 1) = EssName
                         Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                         Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                         ValVer(RdmAry(NN), 1) = 0
                         Exit For
                     End If
                 End If
             Next
         Next

         NN = 0
         Do
             LeftToGo = Tgt - Ruikei 'あと幾ら必要かチェックする
             If LeftToGo = 0 Then
                 'ピッタリ→終了
                 Fenito = True
                 Exit Do
             ElseIf LeftToGo < 0 Then
                 'ピッタリにならない→やり直し
                 Exit Do
             Else
                 'ピッタリ必要な数値があるかチェックする
                 Pos = Application.Match(LeftToGo, ValVer, 0)
                 If IsNumeric(Pos) Then '最後を発見
                     numChosen = numChosen + 1
                     Selected(numChosen, 1) = ValName(Pos, 1)
                     Selected(numChosen, 2) = ValVer(Pos, 1)
                     Ruikei = Ruikei + ValVer(Pos, 1)
                     ValVer(Pos, 1) = 0
                     Fenito = True
                     Exit Do
                 End If

                 NN = NN + 1

                 If ValVer(RdmAry(NN), 1) > 0 Then
                     numChosen = numChosen + 1
                     Selected(numChosen, 1) = ValName(RdmAry(NN), 1)
                     Selected(numChosen, 2) = ValVer(RdmAry(NN), 1)
                     Ruikei = Ruikei + ValVer(RdmAry(NN), 1)
                     ValVer(RdmAry(NN), 1) = 0
                 End If
             End If
         Loop

     Loop Until Fenito Or Tried >= 5 'トライ回数を5回とした場合
     Wsh.Range("D1:E10000").ClearContents

     If Fenito Then
         Debug.Print Tried
         Wsh.Range("D1").Resize(numChosen, 2).Value = Selected
     Else
         MsgBox Tried & "回トライしましたが発見できませんでした。再トライしてください"
         Exit Sub
     End If

 End Sub

（半平太） 2018/04/27(金) 15:21

 こんばんは！

 私もちょっと時間が出来たので書いてみました。

 Matchの照合の型を利用してみました。

 考え方は、ヘルプより

 Matchは

 照合の型に 0 を指定すると、検査値に一致する値のみが検索の対象となります。

 照合の型に 1 を指定すると、検査値以下の最大の値が検索されます。

 照合の型に -1 を指定すると、検査値以上の最小の値が検索されます。

 となります。

 これを利用して、一割を等分して各キーから目標値以下の最大値を取得します。

 ちょうどの目標値があればそれを採用します。

 一割から不足分を算出して以上の流れで再帰します。

 並び替えはクイックソートで並び替えました。

 一応、データの部分は省略していますが、F:G列に↓こんな感じになりました。

 何かの参考になれば幸いです。

 では、では、

 氏名01	1	氏名01		氏名01	48
 氏名01	6	氏名02		氏名02	48
 氏名01	7	氏名04		氏名04	50
 氏名01	8	氏名05		氏名05	45
 氏名01	14			氏名04	40
 氏名01	14			合計	231
 氏名01	15					
 氏名01	16					
 ご提示のデータが続きます。

 以上をコードにすると、

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim MyC() As Variant
Dim MyAry() As Variant
Dim MyKey As Variant
Dim x As Variant
Dim r As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim k As Long
Dim S As Long
Dim 目標値 As Long
Dim 一割 As Long
Dim 不足分 As Double
'データをMyAに取得
MyA = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
'一割を算出
一割 = Int(Application.Sum(Application.Index(MyA, , 2)) * 0.1)
'クイックソートで並び替え
QuickSort MyA, 2, LBound(MyA, 1), UBound(MyA, 1)
'抽出用のデータをMyBに取得
MyB = Range("D1", Range("D" & Rows.Count).End(xlUp)).Resize(, 2).Value
'MyAryの準備
ReDim MyAry(1 To 2, 1 To UBound(MyB, 1))
'一割を等分した目標値を算出
目標値 = Int(一割 / UBound(MyB, 1))
'キー分のMyKeyを準備
ReDim MyKey(1 To UBound(MyB, 1))
'個々の配列を準備
For i = LBound(MyB, 1) To UBound(MyB, 1)
    MyKey(i) = Range("D" & i).Resize(, 2).Value
Next
k = 1
'個々の配列を作成
For n = LBound(MyKey) To UBound(MyKey)
    For i = LBound(MyA, 1) To UBound(MyA, 1)
        If MyA(i, 1) = MyKey(n)(1, 1) Then
            If MyA(i, 2) > 0 Then
                k = k + 1
                x = MyKey(n)
                ReDim Preserve x(1 To 1, 1 To k)
                x(1, k) = Val(MyA(i, 2))
                MyKey(n) = x
            End If
        End If
    Next
Next
For n = LBound(MyKey) To UBound(MyKey)
    x = MyKey(n)
        '目標値があるか検索
        r = Application.Match(目標値, Application.Index(x, 1, 0), 0)
        '目標値がない場合は、近似値以下で最大値を取得
        If IsError(r) Then
            r = Application.Match(目標値, Application.Index(x, 1, 0), 1)
        End If
        'MyAryに代入
        MyAry(1, n) = x(1, 1)
        If x(1, r) = Empty Then
            MyAry(2, n) = 0
        Else
            MyAry(2, n) = x(1, r)
        End If
        '使用した値は　0　にする
        x(1, r) = 0
    MyKey(n) = x
    k = k + UBound(x, 2) - 1
Next
k = 0
S = 0
'バラバラになった配列をMyCに統合
For n = LBound(MyKey) To UBound(MyKey)
    x = MyKey(n)
    k = k + UBound(x, 2) - 1
    ReDim Preserve MyC(1 To 2, 1 To k)
    For j = 2 To UBound(x, 2)
        MyC(1, S + j - 1) = x(1, 1)
        MyC(2, S + j - 1) = Val(x(1, j))
    Next
    S = S + UBound(x, 2) - 1
Next
'行列を入れ替えて
MyC = Application.Transpose(MyC)
'最終的な不足分を算出
不足分 = (一割 - Application.Sum(Application.Index(MyAry, 2, 0))) + 1
'再帰　不足分探索に引数を渡して探索
不足分探索 MyC, MyAry, 不足分, 一割
'結果を出力
ReDim Preserve MyAry(1 To 2, 1 To UBound(MyAry, 2) + 1)
MyAry(1, UBound(MyAry, 2)) = "合計"
MyAry(2, UBound(MyAry, 2)) = "=SUM(G1:G" & UBound(MyAry, 2) - 1 & ")"
Range("F:G").Clear
Range("F1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
Erase MyA, MyB, MyC, MyAry, MyKey, x
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As String
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
    Do
        Do While MySAry(i, MySKey) < MySMid
            i = i + 1
        Loop
        Do While MySAry(j, MySKey) > MySMid
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For n = MySLBound To MySUBound
            MyStmp = MySAry(i, n)
            MySAry(i, n) = MySAry(j, n)
            MySAry(j, n) = MyStmp
        Next
        i = i + 1
        j = j - 1
    Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
Sub 不足分探索(ByRef MyC As Variant, ByRef MyAry As Variant, ByRef 不足分 As Double, ByVal 一割 As Double)
Dim r As Variant
Dim 仮不足分 As Double
Dim i As Long
Dim j As Long
不足分 = (一割 - Application.Sum(Application.Index(MyAry, 2, 0))) + 1
仮不足分 = 不足分
'クイックソートで並び替え
QuickSort MyC, 2, LBound(MyC, 1), UBound(MyC, 1)
'ゴミが混じるのでValで清掃
For i = LBound(MyC, 1) To UBound(MyC, 1)
    MyC(i, 2) = Val(MyC(i, 2))
Next
'ちょうどの不足分があるか検索
r = Application.Match(不足分, Application.Index(MyC, 0, 2), 0)
'不足分がない場合は、近似値以上で最小値を取得
If IsError(r) Then
    r = Application.Match(不足分, Application.Index(MyC, 0, 2), -1)
End If
'不足分以上の近似値がない場合は、近似値以下の最大値を取得
If IsError(r) Then
    r = Application.Match(不足分, Application.Index(MyC, 0, 2), 1)
End If
'エラーでなくて　0　以上　だったら　MyAryに代入
If Not IsError(r) Then
    If MyC(r, 2) > 0 Then
        'MyAryに代入
        ReDim Preserve MyAry(1 To 2, 1 To UBound(MyAry, 2) + 1)
        MyAry(1, UBound(MyAry, 2)) = MyC(r, 1)
        MyAry(2, UBound(MyAry, 2)) = MyC(r, 2)
        '使用した値は　0　にする
        MyC(r, 2) = 0
    End If
End If
不足分 = (一割 - Application.Sum(Application.Index(MyAry, 2, 0))) + 1
If 仮不足分 > 不足分 Then 不足分探索 MyC, MyAry, 不足分, 一割
End Sub
v(=∩_∩=)v
（SoulMan） 2018/04/28(土) 00:47

 >最下行でエラーが発生するケースが多かったです。。 
 すいません。
 根本的にロジックが不十分でした。

 >抽出対象内のメンバーのみ
 >与えられたデータの1行目の値を超える最小値となる組み合わせ
 >与えられたデータ内のメンバーは最低1回は出てこないといけません。 
 1つ目の条件があると、基準値+1になる組み合わせが限られてきますね。
 ご提示のデータですと「氏名07」「氏名08」の組合せの時や、「氏名04」～「氏名08」単独の時は、
 基準値+1になる解が存在しないので、そう言う時は基準値+2以上の結果を表示させるんですよね？

 解が無いと言う事を証明する為には、総当たり以外に証明する方法はありません。

 唯一の救いは、ご提示のようなデータですと、組合せに使用する条件が1件ないし2件などの少ない時くらいしか、
 解が存在しない時は無さそうなので、以下のようなコードでもそれほど時間はかからないと思います。 
 (条件が8個から1個まで全てテストした限りでは、私の相当遅いPCで一番遅い時でも20秒はかかりませんでした)
 (解が存在しない時のみ、最終的に総当たりになります)

 Sub test2()
    Dim sh As Worksheet
    Dim r As Range
    Dim i As Long
    Dim m As Long
    Dim lRow As Long
    Dim dCnt() As Long
    Dim v As Variant
    Dim subT As Long

    '初期化
    Set sh = Sheets("マクロ検索")
    sh.Range("F:XFD").ClearContents

    '抽出データ
    sh.Range("A1").CurrentRegion.Copy sh.Range("I2")
    sh.Range("D1").CurrentRegion.Copy sh.Range("L1")
    sh.Range("L1").CurrentRegion.Offset(, 1).Value = ">0"
    sh.Range("I1:J1,L1:M1,O1:P1").Value = Array("氏名", "数")
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh.Range("J1"), Order:=xlDescending
        .SetRange sh.Range("I1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    sh.Range("I1").CurrentRegion.AdvancedFilter xlFilterCopy, sh.Range("L1").CurrentRegion, sh.Range("O1:P1"), False
    With sh.Range("O1").CurrentRegion
        .Resize(.Rows.Count - 1, 1).Offset(1, 2).Formula = "=MAX(0,COUNTIFS(F:F,O2,G:G,P2)-COUNTIFS(O$1:O1,O2,P$1:P1,P2))"
    End With

    '結果欄
    sh.Range("D1").CurrentRegion.Offset(1).Copy sh.Range("F1")
    With sh.Range("F1").CurrentRegion.Offset(, 1)
        .Formula = "=AGGREGATE(14,6,(I$2:I$300=F1)*J$2:J$300,1)"
        .Value = .Value
    End With
    sh.Range("I:M").ClearContents
    sh.Range("I1").Formula = "=SUM(G:G)"
    sh.Range("I2").Formula = "=D1-I1+1"
    If sh.Range("I2").Value = 0 Then Exit Sub
    If WorksheetFunction.Sum(sh.Range("P:P")) < sh.Range("D1").Value + 1 Then
        sh.Range("O1").CurrentRegion.Offset(1).Resize(, 2).Copy sh.Range("F1")
        Exit Sub
    End If
    subT = -1000
    If sh.Range("I2").Value < 0 Then
        v = sh.Range("F1").CurrentRegion.Value
        subT = sh.Range("I2").Value
    End If

    '検索
    lRow = sh.Range("F1").CurrentRegion.Rows.Count
    ReDim dCnt(1 To lRow, 1 To 2)
    For i = 1 To lRow
        dCnt(i, 1) = 1
        dCnt(i, 2) = WorksheetFunction.CountIf(sh.Range("O:O"), sh.Range("F" & i))
    Next i
    For i = lRow To 1 Step -1
        If sh.Range("I2").Value < 0 Then
            If sh.Range("G" & i).Value < -sh.Range("I2").Value Then
                Set r = sh.Range("F" & i)
                r.Offset(, 1).Value = Evaluate("AGGREGATE(15,6,1/(O2:O500=" & r.Address & ")*P2:P500,1)")
            Else
                If WorksheetFunction.CountIfs(sh.Range("O:O"), sh.Range("F" & i), _
                        sh.Range("P:P"), sh.Range("G" & i) + sh.Range("I2"), sh.Range("Q:Q"), 0) Then
                    Range("G" & i).Value = Range("G" & i).Value + sh.Range("I2").Value
                    Exit Sub
                End If
            End If
        End If
    Next i

    Do
step2:
        If sh.Range("I2").Value > 0 Then
            With sh.Range("G" & Rows.Count).End(xlUp).Offset(1)
                If WorksheetFunction.CountIfs(sh.Range("P:P"), sh.Range("I2"), sh.Range("Q:Q"), 0) Then
                    .Value = sh.Range("I2").Value
                Else
                    If WorksheetFunction.CountIfs(sh.Range("P:P"), "<=" & sh.Range("I2"), sh.Range("Q:Q"), 0) Then
                        .Value = Evaluate("AGGREGATE(14,6,(P2:P500<=I2)*(Q2:Q500=0)*P2:P500,1)")
                    Else
                        .Value = Evaluate("AGGREGATE(15,6,1/((P2:P500>=I2)*(Q2:Q500=0))*P2:P500,1)")
                    End If
                End If
                .Offset(, -1).Value = Evaluate("INDEX(O:O,MATCH(1,INDEX(0/((P1:P500=" & .Value & ")*(Q1:Q500=0)),0)))")
            End With
            If sh.Range("I2").Value = 0 Then Exit Sub
            If sh.Range("I2").Value < 0 And sh.Range("I2").Value > subT Then
                v = sh.Range("F1").CurrentRegion.Value
                subT = sh.Range("I2").Value
            End If
        Else
            If sh.Range("G" & Rows.Count).End(xlUp).Row > lRow Then
                For i = sh.Range("G" & Rows.Count).End(xlUp).Row To lRow + 1 Step -1
                    If WorksheetFunction.CountIfs(sh.Range("P:P"), "<=" & sh.Range("G" & i) + sh.Range("I2"), sh.Range("Q:Q"), 0) Then
                        With sh.Range("G" & i)
                            .Value = Evaluate("AGGREGATE(14,6,(P2:P500<=" & .Value & "+I2)*(Q2:Q500=0)*P2:P500,1)")
                            .Offset(, -1).ClearContents
                            .Offset(, -1).Value = Evaluate("INDEX(O:O,MATCH(1,INDEX(0/((P1:P500=" & .Value & ")*(Q1:Q500=0)),0)))")
                        End With
                    End If
                    If WorksheetFunction.CountIf(sh.Range("G:G"), -sh.Range("I2")) Then
                        Set r = sh.Range("F" & WorksheetFunction.Match(-sh.Range("I2"), sh.Range("G:G"), 0))
                        If WorksheetFunction.CountIf(sh.Range("F:F"), r) <> 1 Then
                            r.Resize(, 2).ClearContents
                            With sh.Range("F" & Rows.Count).End(xlUp).Resize(, 2)
                                r.Resize(, 2).Value = .Value
                                .ClearContents
                            End With
                            Exit Sub
                        End If
                    End If
                    If sh.Range("I2").Value = 0 Then Exit Sub
                    If sh.Range("I2").Value < 0 And sh.Range("I2").Value > subT Then
                        v = sh.Range("F1").CurrentRegion.Value
                        subT = sh.Range("I2").Value
                    End If
                    If sh.Range("I2").Value > 0 Then GoTo  step2
                Next i
            End If
            i = 0
            Do
                sh.Range("F" & lRow + 1).Resize(300, 2).ClearContents
                i = i + 1
                If i > UBound(dCnt, 1) Then Exit Do
                If dCnt(i, 1) < dCnt(i, 2) Then
                    Set r = sh.Range("G" & i)
                    dCnt(i, 1) = dCnt(i, 1) + 1
                    If WorksheetFunction.CountIfs(sh.Range("O:O"), r.Offset(, -1).Value, _
                            sh.Range("P:P"), "<" & r.Value, sh.Range("Q:Q"), 0) Then
                        r.Value = Evaluate("AGGREGATE(14,6,(O2:O500=" & r.Offset(, -1).Address & _
                                ")*(P2:P500<" & r.Value & ")*(Q2:Q500=0)*P2:P500,1)")
                    Else
                        dCnt(i, 1) = dCnt(i, 2)
                    End If
                    i = 0
                    Exit Do
                Else
                    If dCnt(UBound(dCnt, 1), 1) = dCnt(UBound(dCnt, 1), 2) Then GoTo step1
                    dCnt(i, 1) = 1
                    Set r = sh.Range("G" & i)
                    r.Value = Evaluate("AGGREGATE(14,6,(O2:O500=" & r.Offset(, -1).Address & ")*(Q2:Q500=0)*P2:P500,1)")
                End If
            Loop
            If sh.Range("I2").Value < 0 And sh.Range("I2").Value > subT Then
                v = sh.Range("F1").CurrentRegion.Value
                subT = sh.Range("I2").Value
            End If
        End If
        m = m + 1
    Loop Until m = 500
 step1:

    sh.Range("F1").CurrentRegion.ClearContents
    sh.Range("F1:G1").Resize(UBound(v, 1)).Value = v

 End Sub

（sy） 2018/04/29(日) 23:27

コメント返信：

[ 一覧(最新更新順) ]

[[20180424173356]] 『組み合わせの抽出』（運慶） ページの最後に飛ぶ

[[20180424173356]]　『組み合わせの抽出』（運慶）　ページの最後に飛ぶ