スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その13 


副題:長さの種類の組み合わせ

組合せ合計値の検索は、過去記事「Excel VBA をやってみた その11」とか・・・
そこから色々な記事に飛べますね

今回は、長さの種類の組み合わせ・・・ということで、

全長:5200mm の棒を効率よく切っていきたい
切る長さは 520mm / 580mm / 730mm / 980mm / 1030mm / 1240mm の6種類
端材は 50mm ・・・ (おそらくは、切りしろを加味した長さ?)
なので、各種類を加算して 5150mm に近いもののパターン求めたい

考え方として、
各種類が 5150mm で何本取れるか・・・で
520mm なら9本取れるので、520 / 520 / ・・・ / 520 の9つのデータに展開して・・・
他の種類についても、同様にデータ展開して・・・ 
組合せ合計値の検索を使って求める・・・ でも良いかもしれない・・・???

でも、せっかくなので・・・
各種類を何本使っているかの管理でやってみようか・・・

で、回答してみたのが以下です・・・
黄色い表示の部分・・・ これ、処理を見なおして修正しています(後述 Samp2 として)
現状のままでも、実害はないのですが・・・

参考程度で

以下を実行すると、添付図のような結果が表示されます。
上書きする場合は、2行2列余計にクリアしてから出力します。

Public Sub Samp1()
  Dim dic As Object
  Dim vA As Variant, v As Variant
  Dim iA() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long, j As Long
  Const CMAXLEN As Long = 5200 ' 全長
  Const CREMLEN As Long = 50 ' 残す
  Const COKLEN As Long = 30 ' 許容差

  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN)
  ReDim iA(UBound(vA))
  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  iPos = 0
  Do While ((0 <= iPos) And (iPos <= UBound(vA)))
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA)
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        Else
          iPos = iPos - 1
        End If

      Loop
    End If
  Loop

  If (dic.Count > 0) Then
    With Range("A1")
      .Resize(dic.Count + 3, UBound(vA) + 3).Clear
      .Value = "残 mm"
      With .Offset(, 1).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
      End With
      With .Offset(1).Resize(dic.Count)
        .Value = WorksheetFunction.Transpose(dic.Items)
        .TextToColumns .Cells(1), xlDelimited, Comma:=True
        With .Resize(, UBound(vA) + 1)
          .Sort .Cells(1), xlAscending, Header:=xlNo
          With .Offset(, 1).Resize(, .Columns.Count - 1)
            .NumberFormatLocal = "0 ""本"""
          End With
        End With
      End With
    End With
  End If
  Set dic = Nothing
End Sub

厳密に記述すると

>     For i = 0 To UBound(iA)
部分は
     For i = 0 To UBound(iA) - 1
と・・・
すべきかと・・・・

出力結果の範囲+2行2列をクリアしてから書き出しするので、1列分余計に空白のデータを作っていても実害はない・・・かな?


結果として表示されるのは、以下のようになります。
(修正した Samp2 の表示も同じです)

kEnt206Samp1.jpg

上記記述では、
  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN)
部分を変更することで、表示が変わるようになっています。
ただ、記述する順は昇順になるように・・・ これ、暗黙であります。
また、1番短いものは、許容差(COKLEN)より大きい事・・・ これも、暗黙であります。
さて、次に用意した Samp3 では、
  vA = Array(350, 480, 520, 580, 680, 730, 880, 980, 1030, 1170, 1240, CMAXLEN + 1)
に変更して、結果表示部分に色気を出して・・・ 以下の様な感じに

kEnt206Samp3.jpg

A列の「使用 mm」部分は、検算も兼ねて、1行目の mm と求めた本数とを SUMPRODUCT
「本数」部分には SUM、「種類数」部分には COUNT
を設定しています。

使っていくうちに、データが変わった・・・ さて、VBA 部分を書き換えるのも面倒・・・
という事で、Samp3 をシートに設定したデータで動くようにしたのが Samp4 と Sheet1

kEnt206Sheet1.jpg  kEnt206Samp4.jpg

せっかくなので、最低必要数も与えて・・・ Samp4 を元に変更したのが Samp5 と Sheet2

kEnt206Sheet2.jpg  kEnt206Samp5.jpg

kEnt206Sheet2_2.jpg  kEnt206Samp5_2.jpg

kEnt206Sheet2_3.jpg  kEnt206Samp5_3.jpg

※ シート上「サイズ」を入力する枠は10個分の所にしていますが、実際には意味ありません。
 C6 ~ その行の右端のものまでを対象にしています。
 
では、回答した Samp1 を変更していきます。
(Samp1 でも実害はありませんが、後々困らない為?に・・・)

・使っていない変数の宣言を削除
 ここは、For とか For Each とか試してみて・・・ の、残骸です

・Const CREMLEN As Long = 50 ' 残す ・・・これが 0 で指定される事はない?
 例えば、1つ切り出すのに 5mm 幅が必要で・・・9本切ったとして (9-1)*5 = 40 mm
 時に 5mm が 4mm だったり面倒なので 50mm 換算・・・・
 っていう意味と思ってますが、もし 0 mm が設定された場合を想定して、
 vA 最後のストッパとして、全長+1にしておく
  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN)

  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)

・Do While ループで Exit Do する事が無ければ、While~Wend 記述にする(マイブームということで)
 また、必要な条件だけに記述を絞る
  Do While ((0 <= iPos) And (iPos <= UBound(vA)))

  While (iPos >= 0)

・リストアップした文字列を、キッチリとしたデータ範囲で
      For i = 0 To UBound(iA)

      For i = 0 To UBound(iA) - 1

・前に戻る処理の際、無駄に多くループしない様に
        Else
          iPos = iPos - 1
        End If

        End If
        iPos = iPos - 1

修正を入れた全体は以下

Public Sub Samp2()
  Dim dic As Object
  Dim vA As Variant
  Dim iA() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long
  Const CMAXLEN As Long = 5200 ' 全長
  Const CREMLEN As Long = 50 ' 残す
  Const COKLEN As Long = 30 ' 許容差

  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)
  ReDim iA(UBound(vA))
  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  iPos = 0
  While (iPos >= 0)
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA) - 1
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        End If
        iPos = iPos - 1

      Loop
    End If
  Wend

  If (dic.Count > 0) Then
    With Range("A1")
      .Resize(dic.Count + 3, UBound(vA) + 3).Clear
      .Value = "残 mm"
      With .Offset(, 1).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
      End With
      With .Offset(1).Resize(dic.Count)
        .Value = WorksheetFunction.Transpose(dic.Items)
        .TextToColumns .Cells(1), xlDelimited, Comma:=True
        With .Resize(, UBound(vA) + 1)
          .Sort .Cells(1), xlAscending, Header:=xlNo
          With .Offset(, 1).Resize(, .Columns.Count - 1)
            .NumberFormatLocal = "0 ""本"""
          End With
        End With
      End With
    End With
  End If
  Set dic = Nothing
End Sub

 
  iClen = CMAXLEN - CREMLEN
  iPos = 0
  While (iPos >= 0)
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA) - 1
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        End If
        iPos = iPos - 1
      Loop
    End If
  Wend

上記の処理概要は以下

  Const CMAXLEN As Long = 550 ' 全長
  Const CREMLEN As Long = 50 ' 残す
  Const COKLEN As Long = 20 ' 許容差

  vA = Array(240, 490, CMAXLEN + 1)
上記データを処理する流れは
・全長 - 残す・・・
これを iClen で持って、順次、減算/加算を繰り返して、許容差以内になるものを探す。
何回引いたかは、iA() の配列で管理

 iClen  iPos iA
5000 (0)=0,(1)=0,(2)=0
 vA(0)=240 の値をドンドン引いていく
2600 (0)=1,(1)=0,(2)=0
200 (0)=2,(1)=0,(2)=0
200 (0)=2,(1)=0,(2)=0
 許容差以内なのでリストアップ
 今のままの iPos 位置では以降解はないので、
 現在の iPos の内容 vA(0)=240 を iClen  に戻してカウント-1 
 iPos を 1 進めて
 以下の状態にし処理継続
2601 (0)=1,(1)=0,(2)=0
 vA(1)=490 以下なので Else の Do へ
   (1)=0なので iPos を -1 戻す
 (0)=1 なので vA(0) の 240 を iClen に戻してカウント-1 
 iPos を 1 進めて、次の候補を探す様にする
5001 (0)=0,(1)=0,(2)=0
 iClen >= vA(1):490 なので Exit Do
5001 (0)=0,(1)=0,(2)=0
 vA(1)=490 の値をドンドン引いていく
101 (0)=0,(1)=1,(2)=0
101 (0)=0,(1)=1,(2)=0
 許容差以内なのでリストアップ
 今のままの iPos 位置では以降解はないので、
 以下の状態に戻し処理継続
5002 (0)=0,(1)=0,(2)=0
 vA(2)=551 以下なので Else の Do へ
 <>0 が無いので iPos は -1 に
 Do While のループを抜ける
500-1 (0)=0,(1)=0,(2)=0
While~Wendループを抜ける
リストアップされたのは以下の2つ
200 (0)=2,(1)=0,(2)=0 文字列として "70,2,"
101 (0)=0,(1)=1,(2)=0 文字列として "60,,1"

となります。
リストアップされる文字列、"70,2," "60,,1" の格納先に Dictionary の Item を利用していました。
Dictionary を使わなくてはならない・・・・ という事はありません。
例えば、
  Dim sA() As String
  Dim iCnt As Long
    と変数を宣言しておいて
  iCnt = 0
    カウンタを初期化しておいてから
    文字列が出来上がったら
  ReDim Preserve sA(iCnt)
  sA(iCnt) = sS
  iCnt = iCnt + 1
でも同じ事ですが、Dictionary を使うと
      dic(dic.Count) = sS
だけで出来るので・・・
キーは、重複しない様に dic.Count を使って・・・初期は 0 で、1つ登録すると 1 になってくれる
オートナンバの様に使いやすいのかな・・・・

結果の出力時は、
  If (dic.Count > 0) Then
    With Range("A1")
      .Resize(dic.Count + 3, UBound(vA) + 3).Clear
      .Value = "残 mm"
      With .Offset(, 1).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
      End With
      With .Offset(1).Resize(dic.Count)
        .Value = WorksheetFunction.Transpose(dic.Items)
        .TextToColumns .Cells(1), xlDelimited, Comma:=True
        With .Resize(, UBound(vA) + 1)
          .Sort .Cells(1), xlAscending, Header:=xlNo
          With .Offset(, 1).Resize(, .Columns.Count - 1)
            .NumberFormatLocal = "0 ""本"""
          End With
        End With
      End With
    End With
  End If
この部分を、言葉に置き換えると以下のようになります
  リストアップしたのがあったら
    書き出しの基準を決めて、以降これからの相対で出来上がるように
      結果書き出し範囲+2行2列分を Clear (以後、Delete や 新シートに変化)
      書き出し基準の項目設定
      その右横に指定された各長さを項目として書き出し&書式設定
      データ部分の範囲指定(基準セルの1行下からデータ分(dic.Count分))
        文字列の書き出し
        書き出した文字列をカンマ区切りで横に展開
        横展開した領域全てを範囲指定
          「残 mm」部分を指定してソート
          範囲を右1つ移動し、列幅-1した範囲で書式を設定

※ 上記での書き出し位置は A1 になっていますが、B5 とかに変更すると、そこから表が出来上がります。

※ 各長さの項目作成部分の範囲を .Resize(, UBound(vA)) で指定して .Value = vA しています。
なぜ、その内容になったのかは、
  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)
では、vA(0) ~ vA(6) で計7つですが、必要なのは vA(0) ~ vA(5) の6つ
この添え字部分を見ると、必要数 = UBound(vA) なので、範囲として .Resize(, UBound(vA))
この範囲(6つ分)に7つある vA を代入すると、6つ分( vA(0) ~ vA(5) )だけが・・・
ストッパとして使っていた vA(6) は、代入されない事に・・・ という式になってます

※ 「文字列の書き出し」部分で、普通の配列を縦に展開したいので Transpose を使っています。
64k の要素数を超えた場合はエラーになるようです。
xls で使っている分には、元々行は 64k までなので気付きませんが、
xlsm とかで、64k を超えるものを Transpose しようとすると・・・・・ ポンとエラーに・・・

※ 「残 mm」部分を指定してソートしてますが、この1行をコメントにすると処理した順がわかる?かも


実際には、Samp2 で完成とすればそれまでですが、
求める処理部分を書き換えずに、
  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)

  vA = Array(350, 480, 520, 580, 680, 730, 880, 980, 1030, 1170, 1240, CMAXLEN + 1)
の変更だけで色々求められるのか・・・・の検証と
結果を表示した時・・・行毎の色分けとか、検算用・・・本数の計、種類数とか・・・色気出したいな・・・
ということで、Samp2 を元に Samp3 を作成
結果を表示する際に、新シートにするかどうか・・・も追加しました。
後、上書きする場合、Samp2 までは、結果範囲+2行2列を Clear していましたが、
データが多くなると何か遅いので、+2行2列に拘らずに Cells.Delete するように・・・
また、データ量が多くなった時に見易いように、ウィンドウ枠の固定もしてみました。

kEnt206Samp3.jpg

Public Sub Samp3()
  Dim dic As Object
  Dim vA As Variant
  Dim iA() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long
  Const CNEWSHEET As Boolean = True ' 結果を新シートに?
  Const CMAXLEN As Long = 5200 ' 全長
  Const CREMLEN As Long = 50 ' 残す
  Const COKLEN As Long = 30 ' 許容差

'  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)
  vA = Array(350, 480, 520, 580, 680, 730, 880, 980, 1030, 1170, 1240, CMAXLEN + 1)
  ReDim iA(UBound(vA))
  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  iPos = 0
  While (iPos >= 0)
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA) - 1
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        End If
        iPos = iPos - 1
      Loop
    End If
  Wend

  If (dic.Count > 0) Then
    If (CNEWSHEET) Then
      Worksheets.Add after:=Worksheets(Worksheets.Count)
    Else
      ActiveWindow.FreezePanes = False
      Cells.Delete
    End If
    With Range("A1")
      .Value = "使用 mm"
      .Offset(, 1).Value = "残 mm"
      With .Offset(, 2).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
        sS = .Address(, , xlR1C1)
        .Cells(1, .Columns.Count + 1) = "本数"
        .Cells(1, .Columns.Count + 2) = "種類数"
      End With
      With .Resize(, UBound(vA) + 4)
        .Interior.ColorIndex = 15
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        With .Offset(1).Resize(dic.Count)
          With .Columns(2)
            .Value = WorksheetFunction.Transpose(dic.Items)
            .TextToColumns .Cells(1), xlDelimited, Comma:=True
            With .Resize(, UBound(vA) + 1)
              .Sort .Cells(1), xlAscending, Header:=xlNo
              With .Offset(, 1).Resize(, .Columns.Count - 1)
                .NumberFormatLocal = "0 ""本"""
              End With
            End With
          End With
          With .Columns(1)
            .FormulaR1C1 = "=SUMPRODUCT(" & sS & ",RC[2]:RC[" & UBound(vA) + 1 & "])"
            .Resize(, 2).NumberFormatLocal = "0 ""mm"""
          End With
          With .Columns(.Columns.Count - 1)
            .FormulaR1C1 = "=SUM(RC[-" & UBound(vA) & "]:RC[-1])"
            .NumberFormatLocal = "0 ""本"""
          End With
          With .Columns(.Columns.Count)
            .FormulaR1C1 = "=COUNT(RC[-" & UBound(vA) + 1 & "]:RC[-2])"
            .NumberFormatLocal = "0 ""個"""
          End With
          For i = 1 To .Rows.Count
            .Rows(i).Interior.ColorIndex = IIf(i Mod 2, 34, 36)
          Next
        End With
        .Resize(dic.Count + 1).Borders.LineStyle = xlContinuous
        .Columns.AutoFit
      End With
      .Offset(1, 2).Activate
      ActiveWindow.FreezePanes = True
      .Activate
    End With
  End If
  Set dic = Nothing
End Sub

 
結果出力部分を言葉で書き換えてみると以下のようになります
  リストアップしたのがあったら
    新シート作成なら、シートを作って
    でなかったら、ウィンドウ枠固定を解除して、全セルを削除
    書き出しの基準を決めて、以降これからの相対で出来上がるように
      書き出し基準の項目設定
      (「使用 mm」右横に「残 mm」)
      その右横に指定された各長さを項目として書き出し&書式設定
      この範囲をR1C1形式で絶対アドレスを覚えておく(sS)後で SUMPRODUCT 設定時に利用
      さらに右横に「本数」「種類数」の項目を設定
        .Cells(1, .Columns.Count + 1) = "本数"
        .Cells(1, .Columns.Count + 2) = "種類数"
      End With
↓でも同じことだけど、違う書き方してみた
      End With
      .Offset(, UBound(vA) + 2) = "本数"
      .Offset(, UBound(vA) + 3) = "種類数"
      項目部分全体に範囲を広げて
        背景色、太字、中央寄せを設定
        1行下に移動してから、行方向の範囲をデータ分に(横の範囲はそのまま)
          2列目に文字列展開し、書き出した文字列をカンマ区切りで横に展開
          横展開した領域全てを範囲指定
            2列目(「残 mm」)部分を指定してソート
            範囲を右1つ移動し、列幅-1した範囲で書式を設定
          1列目に検算用の SUMPRODUCT 式を埋め込んで、隣の列と一緒に書式設定
          最後から1つ前の列(本数用)に SUM 埋め込んで、書式設定
          最後の列(種類数)に COUNT 埋め込んで、書式設定
          データの1行目から最後まで、ギッコンバッタンで背景色設定
        全体に範囲を広げて罫線引いて
        列幅を調整して
      ウィンドウ枠を固定して
っていう流れです・・・・

※ リストアップする処理部分の動きは良さそうですね

冒頭でも触れていましたが、vA = Array( ・・・ 部分の変更で色々と対応できそうです。
ただ、条件が変わったとかなると、VBA 記述を書き換えて・・・ って、間違わなければ良いのですが・・・

どうせなら、vA 部分の設定、Const 部分の値・・・・これらを引数(パラメータ)渡しにして、
それら値をシート上から持ってくれば・・・・楽?

という事で、Samp3 を 引数(パラメータ)渡しに記述変更しました(Samp4)
また、シートから各値を持ってくるので、結果は新シートに出す様に
以下、黄色部分が変更した箇所になります。

Public Sub Samp4(vA As Variant _
      , Optional CMAXLEN As Long = 5200 _
      , Optional CREMLEN As Long = 50 _
      , Optional COKLEN As Long = 30
)
  Dim dic As Object
'  Dim vA As Variant
  Dim iA() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long
'  Const CMAXLEN As Long = 5200 ' 全長
'  Const CREMLEN As Long = 50 ' 残す
'  Const COKLEN As Long = 30 ' 許容差

'  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN + 1)
'  vA = Array(350, 480, 520, 580, 680, 730, 880, 980, 1030, 1170, 1240, CMAXLEN + 1)


  ReDim iA(UBound(vA))
  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  iPos = 0
  While (iPos >= 0)
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA) - 1
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        End If
        iPos = iPos - 1
      Loop
    End If
  Wend

  If (dic.Count > 0) Then
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    With Range("A1")
      .Value = "使用 mm"
      .Offset(, 1).Value = "残 mm"
      With .Offset(, 2).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
        sS = .Address(, , xlR1C1)
        .Cells(1, .Columns.Count + 1) = "本数"
        .Cells(1, .Columns.Count + 2) = "種類数"
      End With
      With .Resize(, UBound(vA) + 4)
        .Interior.ColorIndex = 15
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        With .Offset(1).Resize(dic.Count)
          With .Columns(2)
            .Value = WorksheetFunction.Transpose(dic.Items)
            .TextToColumns .Cells(1), xlDelimited, Comma:=True
            With .Resize(, UBound(vA) + 1)
              .Sort .Cells(1), xlAscending, Header:=xlNo
              With .Offset(, 1).Resize(, .Columns.Count - 1)
                .NumberFormatLocal = "0 ""本"""
              End With
            End With
          End With
          With .Columns(1)
            .FormulaR1C1 = "=SUMPRODUCT(" & sS & ",RC[2]:RC[" & UBound(vA) + 1 & "])"
            .Resize(, 2).NumberFormatLocal = "0 ""mm"""
          End With
          With .Columns(.Columns.Count - 1)
            .FormulaR1C1 = "=SUM(RC[-" & UBound(vA) & "]:RC[-1])"
            .NumberFormatLocal = "0 ""本"""
          End With
          With .Columns(.Columns.Count)
            .FormulaR1C1 = "=COUNT(RC[-" & UBound(vA) + 1 & "]:RC[-2])"
            .NumberFormatLocal = "0 ""個"""
          End With
          For i = 1 To .Rows.Count
            .Rows(i).Interior.ColorIndex = IIf(i Mod 2, 34, 36)
          Next
        End With
        .Resize(dic.Count + 1).Borders.LineStyle = xlContinuous
        .Columns.AutoFit
      End With
      .Offset(1, 2).Activate
      ActiveWindow.FreezePanes = True
      .Activate
    End With
  End If
  Set dic = Nothing
End Sub

 
シートを作る前に、簡単なテストを
Public Sub Samp4Test()
  Call Samp4(Array(520, 580, 730, 980, 1030, 1240, 5201))
End Sub
これで動かすと良さそうです。

※ 頻繁に変えないであろう部分は、Optional を使って省略できるように・・・

シートをデザインして、そこから値を入手するようにします。
「サイズ (mm)」部分は、C6 ~ 6行目の入力があった右端までのものを対象にするように・・・
入手したら、昇順にソートして Samp4 の引数に・・・

以下記述を見てわかると思いますが、数値/数字じゃないもの・・・チェックしてません。
また、各数値間のチェックもしてません。
それなりの値を入力して使う事が前提となります。

kEnt206Sheet1.jpg  kEnt206Samp4.jpg

Public Sub UseSamp4()
  Dim r As Range
  Dim iMaxLen As Long, iRemLen As Long, iOkLen As Long
  Dim vA() As Variant
  Dim iCnt As Long
  Dim i As Long, j As Long, k As Long

  iMaxLen = Range("C3")
  iRemLen = Range("C4")
  iOkLen = Range("C5")
  iCnt = 0
  For Each r In Range("C6", Cells(6, Columns.Count).End(xlToLeft))
    If (r <> "") Then
      ReDim Preserve vA(iCnt)
      vA(iCnt) = r
      iCnt = iCnt + 1
    End If
  Next
  ReDim Preserve vA(iCnt)
  vA(iCnt) = iMaxLen + 1
  For i = 0 To UBound(vA) - 1
    For j = i To UBound(vA)
      If (vA(i) > vA(j)) Then
        k = vA(i)
        vA(i) = vA(j)
        vA(j) = k
      End If
    Next
  Next
  Call Samp4(vA, iMaxLen, iRemLen, iOkLen)
End Sub

Public Sub UseSamp5()
  Dim r As Range
  Dim iMaxLen As Long, iRemLen As Long, iOkLen As Long
  Dim vA() As Variant
  Dim iCnt As Long
  Dim i As Long, j As Long, k As Long

  iMaxLen = Range("C3")
  iRemLen = Range("C4")
  iOkLen = Range("C5")
  iCnt = 0
  For Each r In Range("C6", Cells(6, Columns.Count).End(xlToLeft))
    If (r <> "") Then
      ReDim Preserve vA(iCnt)
      vA(iCnt) = r
      iCnt = iCnt + 1
    End If
  Next
  ReDim Preserve vA(iCnt)
  vA(iCnt) = iMaxLen + 1
  For i = 0 To UBound(vA) - 1
    For j = i To UBound(vA)
      If (vA(i) > vA(j)) Then
        k = vA(i)
        vA(i) = vA(j)
        vA(j) = k
      End If
    Next
  Next
  Call Samp5(vA, , iMaxLen, iRemLen, iOkLen)
End Sub

 
※ ここでは、後述する Samp5 用も記述しています。
引数の、「最低必要数」部分を指定しない使い方の検証用になってるかも・・・

なお、Samp1 / Samp2 も確認出来たら・・・・(シート上の値は何も参照しませんが)
以下の記述を追加して、ボタンクリックで起動できるように・・・

Public Sub Samp1NewSheet()
  Worksheets.Add after:=Worksheets(Worksheets.Count)
  Call Samp1
End Sub

Public Sub Samp2NewSheet()
  Worksheets.Add after:=Worksheets(Worksheets.Count)
  Call Samp2
End Sub


さて、ここまで出来上がったのなら、「最低必要数」も指定したいもの・・・
つまり、サイズの下側に 1 と記述したら、必ずそのサイズのものは 1 本以上のパターンを探す・・・
2 と記述したら、必ずそのサイズのものは 2 本以上のパターンを

kEnt206Sheet2.jpg  kEnt206Samp5.jpg

kEnt206Sheet2_2.jpg  kEnt206Samp5_2.jpg

kEnt206Sheet2_3.jpg  kEnt206Samp5_3.jpg

Samp4 をベースに、Samp5 として記述を変更していきます。
Samp4 からの変更点は、そう多くありません(以下、黄色部分のみ)

Public Sub Samp5(vA As Variant _
      , Optional vB As Variant _
      , Optional CMAXLEN As Long = 5200 _
      , Optional CREMLEN As Long = 50 _
      , Optional COKLEN As Long = 30)
  Dim dic As Object
  Dim iA() As Long, iB() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long, j As Long

  ReDim iA(UBound(vA))
  ReDim iB(UBound(vA))
  If (Not IsMissing(vB)) Then
    For i = 0 To UBound(iB)
      iB(i) = vB(i)
    Next
  End If

  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  For i = 0 To UBound(iB)
    iClen = iClen - vA(i) * iB(i)
  Next

  iPos = 0
  While (iPos >= 0)
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA) - 1
        sS = sS & ","
        j = iA(i) + iB(i)
        If (j <> 0) Then sS = sS & j

      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        End If
        iPos = iPos - 1
      Loop
    End If
  Wend

  If (dic.Count > 0) Then
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    With Range("A1")
      .Value = "使用 mm"
      .Offset(, 1).Value = "残 mm"
      With .Offset(, 2).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
        sS = .Address(, , xlR1C1)
        .Cells(1, .Columns.Count + 1) = "本数"
        .Cells(1, .Columns.Count + 2) = "種類数"
      End With
      With .Resize(, UBound(vA) + 4)
        .Interior.ColorIndex = 15
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        With .Offset(1).Resize(dic.Count)
          With .Columns(2)
            .Value = WorksheetFunction.Transpose(dic.Items)
            .TextToColumns .Cells(1), xlDelimited, Comma:=True
            With .Resize(, UBound(vA) + 1)
              .Sort .Cells(1), xlAscending, Header:=xlNo
              With .Offset(, 1).Resize(, .Columns.Count - 1)
                .NumberFormatLocal = "0 ""本"""
              End With
            End With
          End With
          With .Columns(1)
            .FormulaR1C1 = "=SUMPRODUCT(" & sS & ",RC[2]:RC[" & UBound(vA) + 1 & "])"
            .Resize(, 2).NumberFormatLocal = "0 ""mm"""
          End With
          With .Columns(.Columns.Count - 1)
            .FormulaR1C1 = "=SUM(RC[-" & UBound(vA) & "]:RC[-1])"
            .NumberFormatLocal = "0 ""本"""
          End With
          With .Columns(.Columns.Count)
            .FormulaR1C1 = "=COUNT(RC[-" & UBound(vA) + 1 & "]:RC[-2])"
            .NumberFormatLocal = "0 ""個"""
          End With
          For i = 1 To .Rows.Count
            .Rows(i).Interior.ColorIndex = IIf(i Mod 2, 34, 36)
          Next
        End With
        .Resize(dic.Count + 1).Borders.LineStyle = xlContinuous
        .Columns.AutoFit
      End With
      .Offset(1, 2).Activate
      ActiveWindow.FreezePanes = True
      .Activate
    End With
  End If
  Set dic = Nothing
End Sub

 
※ 「最低必要数」が指定されていたら、処理の初めに iClen から必要分のサイズを引いておく
リストアップする際に、実際のカウントと必要数を加算して文字列を作成する
・・・だけ・・

簡単な以下確認では、良さそう・・・
Public Sub Samp5Test()
  Call Samp5(Array(520, 580, 730, 980, 1030, 1240, 5201) _
        , Array(1, 0, 1, 0, 0, 0, 0))
End Sub

Public Sub Samp5Test2()
  Call Samp5(Array(520, 580, 730, 980, 1030, 1240, 5201))
End Sub


結果も良いみたいなので、Sheet1 を Sheet2 としてコピーして以下記述に変更
変更箇所もそうないですね

Public Sub UseSamp4()
  Dim r As Range
  Dim iMaxLen As Long, iRemLen As Long, iOkLen As Long
  Dim vA() As Variant
  Dim iCnt As Long
  Dim i As Long, j As Long, k As Long

  iMaxLen = Range("C3")
  iRemLen = Range("C4")
  iOkLen = Range("C5")
  iCnt = 0
  For Each r In Range("C6", Cells(6, Columns.Count).End(xlToLeft))
    If (r <> "") Then
      ReDim Preserve vA(iCnt)
      vA(iCnt) = r
      iCnt = iCnt + 1
    End If
  Next
  ReDim Preserve vA(iCnt)
  vA(iCnt) = iMaxLen + 1
  For i = 0 To UBound(vA) - 1
    For j = i To UBound(vA)
      If (vA(i) > vA(j)) Then
        k = vA(i)
        vA(i) = vA(j)
        vA(j) = k
      End If
    Next
  Next
  Call Samp4(vA, iMaxLen, iRemLen, iOkLen)
End Sub

Public Sub UseSamp5()
  Dim r As Range
  Dim iMaxLen As Long, iRemLen As Long, iOkLen As Long
  Dim vA() As Variant, vB() As Variant
  Dim iCnt As Long
  Dim i As Long, j As Long, k As Long

  iMaxLen = Range("C3")
  iRemLen = Range("C4")
  iOkLen = Range("C5")
  iCnt = 0
  For Each r In Range("C6", Cells(6, Columns.Count).End(xlToLeft))
    If (r <> "") Then
      ReDim Preserve vA(iCnt)
      vA(iCnt) = r
      ReDim Preserve vB(iCnt)
      vB(iCnt) = r.Offset(1)
      iCnt = iCnt + 1
    End If
  Next
  ReDim Preserve vA(iCnt)
  vA(iCnt) = iMaxLen + 1
  ReDim Preserve vB(iCnt)
  For i = 0 To UBound(vA) - 1
    For j = i To UBound(vA)
      If (vA(i) > vA(j)) Then
        k = vA(i)
        vA(i) = vA(j)
        vA(j) = k
        k = vB(i)
        vB(i) = vB(j)
        vB(j) = k
      End If
    Next
  Next
  Call Samp5(vA, vB, iMaxLen, iRemLen, iOkLen)
End Sub

 
※ 作っておきながら、何なんですが・・・ Samp5 は必要なんだろうか?
 Samp4 で出来たものを、オートフィルタで絞り込めば同じ事が出来る・・・・
 でも、自分で作ってみる・・・ それで良しとしましょうか・・・
 また、処理の方法を変更して、
 一旦全部求めておいてからオートフィルタを施した状態を表示するとか・・・??


※ 引数(パラメータ)渡しの Samp4 / Samp5 では、記述を読んでわかると思いますが
 配列の LBound は = 0 前提での記述になっています。
 Excel では、= 1 になる場合が多いようですけど・・・・
 ここだけ注意すれば、改造等しやすいかも・・・

【訂正】(11/30)
シートを使って Samp4 / Samp5 を呼び出す時、vA 内を昇順ソートしていましたが
  For i = 0 To UBound(vA) - 1
    For j = i To UBound(vA)
この部分は
  For i = 0 To UBound(vA) - 1
    For j = i + 1 To UBound(vA)
の間違いです
修正してから確かめるなりしてください
(余計な判別を・・・・ 動作自体には影響はないのですが・・・)



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

関連記事

2014/11/28

Category: 解説か

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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