Results of 1 - 1 of about 37655 for IF (0.008 sec.)
- [[20070816144932]]
- #score: 1592
- @digest: 38204e8224810b04fb442acd81b43365
- @id: 32688
- @mdate: 2007-08-18T08:19:33Z
- @size: 16866
- @type: text/plain
- #keywords: dec2 (41156), tbl (14277), リ合 (8505), ubound (7753), mangoos (7357), 組合 (5924), data (5432), flag (4601), preserve (4327), buf (3331), 合せ (2475), 弥太 (2090), の組 (1832), 郎様 (1821), redim (1817), next (1757), ピッ (1657), then (1648), integer (1513), for (1233), to (1100), dic (1072), 不可 (1016), long (995), ジッ (990), 個数 (921), case (912), y (887), 有難 (880), exists (867), end (837), function (828)
- 『合計の検索』（ff）
例えば下記のように A 1 1050 2 136 3 258 ○ 4 341 ○ 5 228 6 226 ○ 7 189 8 225 ○ 9 279 10 188 A1に合致する合計をA2〜A10のデータの中からピックアップ する（○印）ことはできますか? よろしくお願いいたします。 ---- 出来る自信も余り無いのですが、、、、 条件が後出しされるとつらいので先にお聞きします。 1.A2セル以下の実際のデータ量は何行くらいあるのですか? 2.A1セルの値にピッタリ合う組合せですね。 (出来るだけ近いもの、と云うようなアイマイなものではありませんね?） 3.何通りかの組合せがあったとしても、1種類だけでいいですね? (半平太) ---- 提示のものだけでも別の組み合わせがありそうです。 マクロですが、これを実行すると、B列の2,3,7,9,10行目に○がつきます。 (ROUGE) '---- Sub test() Dim dic As Object, a, b As Long, i As Long, buf As String, j As Integer, x, r As Range ReDim a(1 To 2 ^ 9 - 1) For i = 1 To 2 ^ 9 - 1 For j = 1 To 9 If Val(Mid(Format(Val(Dec2(i)), "000000000"), j, 1)) = 1 Then buf = buf & " " & Range("A1").Offset(j).Value End If Next a(i) = Trim(buf) buf = "" Next Set dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a) b = Evaluate(Replace(a(i), " ", "+")) dic(b) = a(i) Next If dic.Exists(Range("A1").Value) Then x = Split(dic(Range("A1").Value)) Else MsgBox "該当の組み合わせなし" Exit Sub End If Range("B2:B10").ClearContents For Each r In [A2:A10] If Not IsError(Application.Match(CStr(r.Value), x, 0)) Then r.Offset(, 1).Value = "○" End If Next End Sub Function Dec2(x As Long) As String Dim i As Long, n As Long, buf As Long n = x Do Until 2 ^ buf > n: buf = buf + 1: Loop For i = buf - 1 To 0 Step -1 If n >= 2 ^ i Then Dec2 = Dec2 & "1": n = n - 2 ^ i Else Dec2 = Dec2 & "0" End If Next End Function ---- Sub SAMPLE1() Dim I As Long For I = 2 To 1000 If (Cells(I, 1) = "") Then Exit For If (Cells(I, 2) = "○") Then Cells(1, 1) = Cells(1, 1) + Cells(I, 1) Next I End Sub 簡単に考えすぎて外してるのかなぁ "○"はB列と考えていいんですか?? （mr_mangoos） ---- mr_mangoosさん、入口と出口が反対でっせ。(ROUGE) ---- 皆様ありがとうございます。思った以上に難しいんですね。 ＞半平太様 1.A2以下最高で50行です。30〜50の間です。 2.ピッタリ合わせたいです。 3.他の組み合わせもできるのであれば欲しいです。 ＞ROUGE様 テストしてみました。凄いです。 バッチリです。有難うございました。 偶然にも別の組み合わせができてしまいましたが、違う組み合わせ をC列にとかは可能なのでしょうか?いや考えて頂くほど滅多に あるとは思えませんのでこれで充分です。本当に助かりました。 ＞mr_mangoos様 有難うございます。説明が悪かったでしょうか? ROUGE様の仰るとおり、逆の操作が欲しかったです。 ---- >1.A2以下最高で50行です。30〜50の間です。 しらみつぶしにチェックするロジックを考えていたのですが、 それでは事実上不可能な程の数です。 私は降りることにいたします。m(__)m (半平太) ---- 50個のデータから4個を選択する場合 230,300通り 50個のデータから3個を選択する場合 19,600通り これらをすべて 計算することになります。 ---- もう少しデータの割り振りを簡素化して 行数を少なくするようにしてみます。 有難うございました。 ff ---- 諦めるのは未だ早い!（笑 こんな塩梅でどうでっか? 2個から5個まで全て組合せがB列以降に抽出されます。 （弥太郎） '---------------------- Sub f_f() Dim i As Long, y As Long, t As Long, f As Long, b As Long, j As Integer Dim flag As Boolean, tbl, fnd_count As Integer, m_row, data() tbl = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row) On Error Resume Next fnd_count = StrConv(InputBox("何個でひろいまひょ?"), vbNarrow) If fnd_count = 0 Then Exit Sub Select Case fnd_count Case 2 For i = 2 To UBound(tbl, 1) If tbl(i, 1) < tbl(1, 1) Then For b = i + 1 To UBound(tbl, 1) If tbl(1, 1) = tbl(i, 1) + tbl(b, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next i Case 3 For i = 2 To UBound(tbl, 1) - 1 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) And UBound(tbl, 1) > y Then For b = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next y End If Next i Case 4 For i = 2 To UBound(tbl, 1) - 2 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) Then For t = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) < tbl(1, 1) Then For b = t + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(t, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next t End If Next y End If Next i Case 5 For i = 2 To UBound(tbl, 1) - 3 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) Then For t = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) < tbl(1, 1) Then For f = t + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(f, 1) < tbl(1, 1) Then For b = f + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(f, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(t, j) = "○" data(f, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next f End If Next t End If Next y End If Next i End Select If Not flag Then MsgBox "その個数での組合せは不可能です!": Exit Sub If j > 255 Then MsgBox "組合せが多すぎて表示でけまへん!": Exit Sub Cells(1, 2).Resize(UBound(tbl, 1), j) = data On Error GoTo 0 End Sub ---- 弥太郎様 いいもの頂きまして有難うございます。 頂いておいて恐縮ですが、現時点では、個数を限定させる のは作業上少し手間かなと思います。（ページ数が多い） でもこの構文、他の利用法が即座に浮かびましたので 思いっきり使わせていただきます。また躓きましたら ご教授願います。 感謝。 ff ---- 諦めるのはまだ早い!（笑 ほならこれどうでっか? 2個から5個までの全ての組合せを抽出します。 勿論抽出個数指定無しでデスヨ。 （弥太郎） '----------------------- Sub f_f2() Dim i As Long, y As Long, t As Long, f As Long, b As Long, j As Integer Dim flag As Boolean, u As Integer, tbl, data() tbl = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row) On Error Resume Next For u = 2 To 5 Select Case u Case 2 For i = 2 To UBound(tbl, 1) If tbl(i, 1) < tbl(1, 1) Then For b = i + 1 To UBound(tbl, 1) If tbl(1, 1) = tbl(i, 1) + tbl(b, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next i Case 3 For i = 2 To UBound(tbl, 1) - 1 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) And UBound(tbl, 1) > y Then For b = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next y End If Next i Case 4 For i = 2 To UBound(tbl, 1) - 2 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) Then For t = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) < tbl(1, 1) Then For b = t + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(t, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next t End If Next y End If Next i Case 5 For i = 2 To UBound(tbl, 1) - 3 If tbl(i, 1) < tbl(1, 1) Then For y = i + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) < tbl(1, 1) Then For t = y + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) < tbl(1, 1) Then For f = t + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(f, 1) < tbl(1, 1) Then For b = f + 1 To UBound(tbl, 1) If tbl(i, 1) + tbl(y, 1) + tbl(t, 1) + tbl(f, 1) + tbl(b, 1) = tbl(1, 1) Then j = j + 1 ReDim Preserve data(1 To UBound(tbl, 1), 1 To j) data(i, j) = "○" data(y, j) = "○" data(t, j) = "○" data(f, j) = "○" data(b, j) = "○" flag = True End If Next b End If Next f End If Next t End If Next y End If Next i End Select Next u If Not flag Then MsgBox "その個数での組合せは不可能です!": Exit Sub If j > 255 Then MsgBox "組合せが多すぎて表示でけまへん!": Exit Sub Cells(1, 2).Resize(UBound(tbl, 1), j) = data On Error GoTo 0 End Sub ---- データが23個までの制限付きですが、改訂しました。 このロジックだと、データがひとつ増えるごとにおよそ2倍の時間がかかるようになりそうです。。。 (ROUGE) '---- Sub test() Dim dic As Object, tbl, a(), x Dim i As Long, j As Integer, n As Integer, b As Long Dim buf As String With Range("A2", Range("A" & Rows.Count).End(xlUp)) If .Rows.Count > 23 Then MsgBox "これ以上は能力の限界です。。。", vbExclamation Exit Sub End If tbl = .Value n = .Rows.Count End With ReDim a(1 To 2 ^ n - 1) For i = 1 To 2 ^ n - 1 buf = Dec2(i) buf = String(n - Len(buf), "0") & buf a(i) = buf buf = "" Next Set dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a) For j = 1 To n If Val(Mid(a(i), j, 1)) = 1 Then buf = buf & " " & tbl(j, 1) End If Next buf = Replace(Trim(buf), " ", "+") b = Evaluate(buf) buf = "" If dic.Exists(b) Then x = dic(b) ReDim Preserve x(UBound(x) + 1) x(UBound(x)) = a(i) dic(b) = x Else dic(b) = Array(a(i)) End If Next Range("B2", Cells(n + 1, Columns.Count)).ClearContents If Not dic.Exists(Range("A1").Value) Then MsgBox "該当の組み合わせはありませんでした。。。" GoTo errhdl End If x = dic(Range("A1").Value) For i = LBound(x) To UBound(x) If i + 1 > Columns.Count Then MsgBox "これ以上の組み合わせがありますが、表示できません。。。" GoTo errhdl End If For j = 1 To Len(x(i)) If Val(Mid(x(i), j, 1)) = 1 Then Range("B1").Offset(j, i).Value = "○" End If Next Next errhdl: Set dic = Nothing Erase tbl, a End Sub Function Dec2(x As Long) As String Dim i As Long, n As Long, buf As Long n = x Do Until 2 ^ buf > n: buf = buf + 1: Loop For i = buf - 1 To 0 Step -1 If n >= 2 ^ i Then Dec2 = Dec2 & "1": n = n - 2 ^ i Else Dec2 = Dec2 & "0" End If Next End Function ---- ししょ〜の試しましたが、速いですね〜。 でもプロシジャ名が予約語に当たるみたいなので、変更した方がよさそうです。 ---- あ、ほんまや（汗 HNをそのままマクロ名にしてしまうクセがついとるもんで、つい^^ 変更しときますた〜。 （弥太郎） (ROUGE) ---- ＞弥太郎様 めちゃめちゃ早いです。成せばなる域に達するのは 自分には到底無理ですね。勉強不足で改造に苦しんでおりますので、 このまま使用させていただきます。有難うございました。 ＞ROUGE様 パソコンが考え込んでしまってそのまま眠りました。 コピペが悪いのかなぁ??EXCELがもう1個起動します。??? 時間とらせて申し訳ありませんでした。 ff... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/200708/20070816144932.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97040 documents and 608045 words.
訪問者：