[[20070816144932]]　『合計の検索』（ff）　ページの最後に飛ぶ

『合計の検索』（ff）

 例えば下記のように

A1に合致する合計をA2～A10のデータの中からピックアップ
する（○印）ことはできますか？
よろしくお願いいたします。

 出来る自信も余り無いのですが、、、、
 条件が後出しされるとつらいので先にお聞きします。

 １．A2セル以下の実際のデータ量は何行くらいあるのですか？

 ２．A1セルの値にピッタリ合う組合せですね。
  　(出来るだけ近いもの、と云うようなアイマイなものではありませんね？）

 ３．何通りかの組合せがあったとしても、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

 簡単に考えすぎて外してるのかなぁ
 "○"はＢ列と考えていいんですか？？
　　　　　　　　　　（mr_mangoos）

 mr_mangoosさん、入口と出口が反対でっせ。(ROUGE)

 皆様ありがとうございます。思った以上に難しいんですね。

 ＞半平太様
1.A2以下最高で50行です。30～50の間です。
2.ピッタリ合わせたいです。
3.他の組み合わせもできるのであれば欲しいです。

 ＞ROUGE様
テストしてみました。凄いです。
バッチリです。有難うございました。
偶然にも別の組み合わせができてしまいましたが、違う組み合わせ
をＣ列にとかは可能なのでしょうか？いや考えて頂くほど滅多に
あるとは思えませんのでこれで充分です。本当に助かりました。

 ＞mr_mangoos様
有難うございます。説明が悪かったでしょうか？
ROUGE様の仰るとおり、逆の操作が欲しかったです。

 >1.A2以下最高で50行です。30～50の間です。
 しらみつぶしにチェックするロジックを考えていたのですが、
 それでは事実上不可能な程の数です。

 私は降りることにいたします。m(__)m　(半平太)

50個のデータから4個を選択する場合　　230,300通り

50個のデータから3個を選択する場合　　19,600通り

これらをすべて　計算することになります。

 もう少しデータの割り振りを簡素化して
行数を少なくするようにしてみます。
有難うございました。　　ff

 諦めるのは未だ早い！（笑
 こんな塩梅でどうでっか？
 2個から5個まで全て組合せがＢ列以降に抽出されます。
     　　　（弥太郎）
 '----------------------
  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

 ししょ～の試しましたが、速いですね～。
 でもプロシジャ名が予約語に当たるみたいなので、変更した方がよさそうです。

 あ、ほんまや（汗
 ＨＮをそのままマクロ名にしてしまうクセがついとるもんで、つい＾＾
 変更しときますた～。
     （弥太郎）

 (ROUGE)

 ＞弥太郎様　めちゃめちゃ早いです。成せばなる域に達するのは
自分には到底無理ですね。勉強不足で改造に苦しんでおりますので、
このまま使用させていただきます。有難うございました。

 ＞ROUGE様　パソコンが考え込んでしまってそのまま眠りました。
コピペが悪いのかなぁ？？EXCELがもう1個起動します。？？？
時間とらせて申し訳ありませんでした。　　　　　　　　　ff

コメント返信：

[ 一覧(最新更新順) ]

[[20070816144932]] 『合計の検索』（ff） ページの最後に飛ぶ

[[20070816144932]]　『合計の検索』（ff）　ページの最後に飛ぶ