スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

重複組み合わせ 


今回から、Excel VBA カテゴリを新設しました

今までも何件か Excel での記事を書いてましたが、
標題が「Excel VBA をやってみた ・・・」じゃぁ・・・内容がピンとこない

カテゴリ新設第1弾として、知恵袋での出来事から・・・
回答したものが、そのままなくなるのは・・・なんだかなぁ ということで

psep0925 さん 2016/12/14 08:03:19 の質問

重複組み合わせについて。
A列にランダムな数字、B列にそれぞれの重複可能数、C2に目標合計値
どの数値をどれだけ組み合わせたらC2の数値になるかを出力したい


これに回答して、解決していたものが・・・・ 何故?
※ 今回の削除は、BA が選ばれて閉じられた後の出来事・・・

2017/01/06 21:55:53 質問者さんによって削除された

kEnt215.jpg
 
以下が回答した内容になります

では、以下でどうなりますか

標準モジュールに記述して、
対象シートをアクティブにした状態で Samp1 を実行してみます

結果は E2 ~ 書出します

※ どのような感じ・・・とか、返信いただけたらと


Public Sub Samp1()
  Dim dic As Object
  Dim vA As Variant, vC As Variant, v As Variant
  Dim jC() As Long
  Dim bPre As Boolean
  Dim i As Long, n As Long

  With ActiveSheet
    With .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
      vA = WorksheetFunction.Transpose(.Cells)
      vC = WorksheetFunction.Transpose(.Offset(, 1))
    End With
    Call mySort(vA, vC)
    n = .Range("C2").Value
    If (n < vA(1)) Then Exit Sub

    Set dic = CreateObject("Scripting.Dictionary")

    ReDim jC(1 To UBound(vA))
    i = UBound(vA)
    While (i <= UBound(vA))
      While ((n >= vA(i)) And (jC(i) < vC(i)))
        jC(i) = jC(i) + 1
        n = n - vA(i)
      Wend
      bPre = False
      If (n = 0) Then
        dic(dic.Count) = jC
        bPre = True
      Else
        For i = i - 1 To 1 Step -1
          If (n >= vA(i)) Then Exit For
        Next
        If (i = 0) Then
          i = 1
          bPre = True
        End If
      End If
      If (bPre) Then
        For i = i To UBound(vA)
          If (jC(i) > 0) Then
            If (i = 1) Then
              n = n + vA(i) * jC(i)
              jC(i) = 0
            Else
              jC(i) = jC(i) - 1
              n = n + vA(i)
              i = i - 1
              Exit For
            End If
          End If
        Next
      End If
    Wend

    Application.ScreenUpdating = False
    With .Range("E2").Resize(, UBound(vA))
      .CurrentRegion.Clear
      .Rows(1).Offset(, 1).Value = vA
      .Rows(2).Offset(, 1).Value = vC
      If (dic.Count > 0) Then
        i = 3
        For Each v In dic.Items
          With .Rows(i)
            .Cells(1).Value = i - 2
            .Offset(, 1).Value = v
          End With
          i = i + 1
        Next
      End If
      With .CurrentRegion
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Range("A1").Borders(xlEdgeBottom).LineStyle = xlNone
        .Rows("1:2").Interior.ColorIndex = 36
        .Columns(1).Interior.ColorIndex = 36
        .Columns.AutoFit
      End With
    End With
    Application.ScreenUpdating = True

    Set dic = Nothing
  End With
End Sub


Private Sub mySort(vA As Variant, vC As Variant)
  Dim v As Variant
  Dim i As Long, k As Long

  k = 0
  v = "Go"
  While (Not IsEmpty(v))
    k = k + 1
    v = Empty
    For i = LBound(vA) To UBound(vA) - k
      If (vA(i) > vA(i + 1)) Then
        v = vA(i)
        vA(i) = vA(i + 1)
        vA(i + 1) = v
        v = vC(i)
        vC(i) = vC(i + 1)
        vC(i + 1) = v
      End If
    Next
  Wend
End Sub

 
速くできる要素はあると思いますが、ソコソコ動くものになっていると思います

※ この回答が消えることは、他にも影響があって・・・
他質問への回答で、ここを参照しつつ・・・・

質問内容
2つの袋に10個の玉を 10,0、9,1、……0,10 のように
わけるわけかたをエクセルでやりたいです!
2つの袋だと手打ちで11個打つだけなのですぐできますが、
3つの袋だと66個、4つの袋だと330個うたないといけません。


回答
おそらく意味合い的に同じになると思うので・・・

エクセルVBA、重複組み合わせについて。画像の
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13167970033

ここで回答した VBA 記述を、標準モジュールに転記して、
A2 ~ A4 に 1 を
B2 ~ B4 に 10 以上を
C2 に 10 を記述後、Samp1 を実行してみます
この結果が 3 袋バージョン??

4 袋バージョン?? は
A2 ~ A5 に 1 を
B2 ~ B5 に 10 以上を
C2 に 10 を

これで、どうなりますか

 
さて、この質問は投票に回ってますが・・・どうなることやら??


この Samp1 の方法は、過去記事「Excel VBA をやってみた その11」にも使えますね
B 列に指定する使える個数を 1 にすれば・・・

出来上がる表には、0 / 1 が並ぶだけで、目がチカチカ??
そこで、使える個数の最大値が =1 なら、
0:空白に、 1:○ に表示させる変更が Samp2 (変更部分を黄色で)

Public Sub Samp2()
  Dim dic As Object
  Dim vA As Variant, vC As Variant, v As Variant
  Dim jC() As Long
  Dim bPre As Boolean
  Dim i As Long, n As Long, k As Long

  With ActiveSheet
    With .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
      vA = WorksheetFunction.Transpose(.Cells)
      vC = WorksheetFunction.Transpose(.Offset(, 1))
      k = WorksheetFunction.Max(vC)
    End With
    Call mySort(vA, vC)
    n = .Range("C2").Value
    If (n < vA(1)) Then Exit Sub

    Set dic = CreateObject("Scripting.Dictionary")

    ReDim jC(1 To UBound(vA))
    i = UBound(vA)
    While (i <= UBound(vA))
      While ((n >= vA(i)) And (jC(i) < vC(i)))
        jC(i) = jC(i) + 1
        n = n - vA(i)
      Wend
      bPre = False
      If (n = 0) Then
        dic(dic.Count) = jC
        bPre = True
      Else
        For i = i - 1 To 1 Step -1
          If (n >= vA(i)) Then Exit For
        Next
        If (i = 0) Then
          i = 1
          bPre = True
        End If
      End If
      If (bPre) Then
        For i = i To UBound(vA)
          If (jC(i) > 0) Then
            If (i = 1) Then
              n = n + vA(i) * jC(i)
              jC(i) = 0
            Else
              jC(i) = jC(i) - 1
              n = n + vA(i)
              i = i - 1
              Exit For
            End If
          End If
        Next
      End If
    Wend

    Application.ScreenUpdating = False
    With .Range("E2").Resize(, UBound(vA))
      .CurrentRegion.Clear
      .Rows(1).Offset(, 1).Value = vA
      .Rows(2).Offset(, 1).Value = vC
      If (dic.Count > 0) Then
        i = 3
        For Each v In dic.Items
          With .Rows(i)
            .Cells(1).Value = i - 2
            .Offset(, 1).Value = v
          End With
          i = i + 1
        Next
      End If
      With .CurrentRegion
        If ((k = 1) And (dic.Count > 0)) Then
          With .Offset(2, 1).Resize(.Rows.Count - 2, .Columns.Count - 1)
            .Replace 0, ""
            .Replace 1, "○"
          End With
        End If

        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Range("A1").Borders(xlEdgeBottom).LineStyle = xlNone
        .Rows("1:2").Interior.ColorIndex = 36
        .Columns(1).Interior.ColorIndex = 36
        .Columns.AutoFit
      End With
    End With
    Application.ScreenUpdating = True

    Set dic = Nothing
  End With
End Sub

 
サンプルは以下
 バージョン 2000 でも
 ファイル kEnt215.zip
 サイズ 42,290
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイル(互換:xls と xlsm)

Sheet1 は、質問のデータ
Sheet2 は、使える個数 1 の過去問
 C4 ~ C23 が 1 つのパターン、C25 ~ C54 がもう 1 つのパターン
 このパターンを A2 ~ へコピーして、C2 を変更しながら
Sheet3 は、袋分け?

Samp2 実行で、それなりに動くかと・・・・
関連記事

2017/01/07

Category: Excel VBA

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。