Results of 1 - 1 of about 37655 for IF (0.008 sec.)
- [[20180424173356]]
- #score: 1592
- @digest: 95a4ffcb21cd179ef7d3f8563772eaaf
- @id: 76193
- @mdate: 2018-04-29T14:27:13Z
- @size: 48492
- @type: text/plain
- #keywords: numchosen (388075), valver (306056), 名01 (283786), rdmary (254942), valname (181703), 名02 (137371), numofdata (137188), ruikei (121672), 名05 (120837), lefttogo (116290), essname (116290), 名03 (109051), fenito (94485), namesofessential (94485), 名04 (93374), tried (83469), 足分 (78488), 一割 (71403), 名07 (63822), selected (51502), 氏名 (47723), 出用 (20107), 用デ (19030), myary (16259), 標値 (14970), wsh (14622), 準値 (12850), 目標 (10542), aggregate (10514), mykey (9737), nn (9382), ッタ (9111)
- 『組み合わせの抽出』（運慶）
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） あと、解は1つあればいいので、ソルバーが使えないかなぁ、なんて思っているんですけども。 （半平太） 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 ---- 本当に3、4人程度だったんですね。 データに「変なクセ」が無さそうなので、現実問題としては楽勝だと思います。 目標ピッタリの組合せが相当有りそうなので、あっという間に解に辿り着けると思います。 <ロジック> 1.各候補にランダムに一つずつ割り振る 2.残りをランダムに選んで目標に達するまで追加する ただし、残りの中に、不足額とピッタリ合致するものがあったら、それを優先採用する。 3.累計が目標より1つでも多くなったら、上記1に戻って、ピッタリな解が得られるまで繰り返す。 実際、そんな、ロジックで作ってみると、殆んど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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201804/20180424173356.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97040 documents and 608045 words.
訪問者：