エクセルで範囲内に入る数字を見つけたい

質問

鋼材計算をしています。
６０００mmで１本なのですが　切断する長さがそれぞれ違います。

例
1250mm を３本
3100mm を２本
4000mm を１本　というように取寸したいのですが
（長さや本数は毎回変わります）
これをエクセルで表を作り　何本必要か。
その際　１本の取寸はどうなのか。知りたいのです。
これを解決する方法を教えてください。

回答No.9

okormazd · ベストアンサー

表の行数を自動で取得する。
r2 = Cells(r1, 1).End(xlDown).Row

並べ替えをする。
Range(Cells(r1, c - 2), Cells(r2, c - 1)).Sort Key1:=Cells(r1, c - 2), Order1:=xlDescending, _
Key2:=Cells(r1, c - 1), Order2:=xlDescending

このsubは、処理対象がActiveSheetなので、
このsubをPersonal.xlsの標準モジュールに書いて、ユーザー設定でマクロボタンに登録しておいて、処理したいシートを開いてボタンをクリックすればどのシートでも処理する。

あなたのやりたいことは実現できますが、わたしはあなた向けのアプリケーションを作っているわけではないので、あとは自分で勉強してください。
それではこれで。

お礼

本当にありがとうございました。
なんとか並べ替えをするところまでは自分でできました。

ここからは自分で頑張ります。
ありがとうございました。

回答No.8

okormazd

たびたびすみません。
ちょっと変えました。これでいいでしょう。
r2を処理したい行数+1に変えればよい。
lmaxを変えれば6000mmじゃない素材にも対応できると思う。

Sub solver3()

'寸法で降順にソートしておくこと。

Dim r1 As Integer, r2 As Integer, c As Integer, n As Integer, lmax As Single
Dim rm As Integer, nrm As Integer, total As Single

r1 = 2
r2 = 25
c = 3
n = 0
lmax = 6000

Range(Cells(r1, c + 2), Cells(r2 + 1, 256)).ClearContents
Cells(r2 + 1, c - 1).FormulaR1C1 = "=SUM(R[" & -(r2 - 1) & "]C:R[-1]C)"
total = Cells(r2 + 1, c - 1)
SolverReset

While total > 0

Range(Cells(r1, c + 1), Cells(r2, c + 1)).FormulaR1C1 = "=RC1*RC[-1]"
Range(Cells(r1, c), Cells(r2, c)) = 1
Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).FormulaR1C1 = "=SUM(R[" & -(r2 - 1) & "]C:R[-1]C)"

rm = r1
nrm = Cells(rm, c - 1)
While nrm = 0
rm = rm + 1
nrm = Cells(rm, c - 1)
Wend
SolverAdd CellRef:=Cells(rm, c), Relation:=3, FormulaText:="1"

SolverOk SetCell:=Cells(r2 + 1, c + 1), MaxMinVal:=1, ValueOf:=lmax, ByChange:=Range(Cells(r1, c), Cells(r2, c))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=1, FormulaText:=Range(Cells(r1, c - 1), Cells(r2, c - 1))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=3, FormulaText:="0"
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=4, FormulaText:="整数"
SolverAdd CellRef:=Cells(r2 + 1, c + 1), Relation:=1, FormulaText:=Format(lmax)

SolverSolve userfinish:=True

Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).Copy
c = c + 3
Cells(r2 + 1, c - 1).PasteSpecial
Range(Cells(r1, c - 1), Cells(r2, c - 1)).FormulaR1C1 = "=RC[-3]-RC[-2]"

total = Cells(r2 + 1, c - 1)

SolverReset

n = n + 1

Columns(n * 3 + 2).EntireColumn.Hidden = True

Wend

Cells(r2 + 1, c) = n

End Sub

お礼

こちらこそ　たびたび質問してその度にお答えして頂いて申し訳ありません(T△T)
かなり近づいてきて喜びもつかの間・・・また問題が生じましたので
何度も質問して心苦しいのですが頼りになるのはokormazd様だけですので
よろしくお願いします。

・やりたい行数に変動が出てしまう場合
　　２４行内で０というサイズ（長さ）があります。
　　例えば　今回は２０行　次回は１７行など・・・。
　　（計算してくれるシートを非表示にして出さないようにしたいので毎回マクロ内のr2の数字を変更する事が難しい。）

・別シート（主シート）にマクロボタンを置き　この計算（別シート）をさせたい

・同時に寸法で降順にソートしておくことが出来るようにしたい

本当に無理難題ばかり言って申し訳ありません。
出来たらシートをそのままお渡しして見て貰いたいくらいなのです(T△T)

マクロが初めてなので無知状態です。申し訳ありません。
どうかよろしくお願いします。

回答No.7

okormazd

#6です。
たびたびすみません。
まちがってました。
下記に直してください。

Sub solver3()

'寸法で降順にソートしておくこと。

r1 = 2
r2 = 7
c = 3
n = 0

Range(Cells(1, c + 2), Cells(10, 256)).ClearContents
Cells(r2 + 1, c - 1).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"
total = Cells(r2 + 1, c - 1)
SolverReset

While total > 0

Range(Cells(r1, c + 1), Cells(r2, c + 1)).FormulaR1C1 = "=RC1*RC[-1]"
Range(Cells(r1, c), Cells(r2, c)) = 1
Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"

rm = r1
nrm = Cells(rm, c - 1)
While nrm = 0
rm = rm + 1
nrm = Cells(rm, c - 1)
Wend
SolverAdd CellRef:=Cells(rm, c), Relation:=3, FormulaText:="1"

SolverOk SetCell:=Cells(r2 + 1, c + 1), MaxMinVal:=1, ValueOf:=6000, ByChange:=Range(Cells(r1, c), Cells(r2, c))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=1, FormulaText:=Range(Cells(r1, c - 1), Cells(r2, c - 1))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=3, FormulaText:="0"
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=4, FormulaText:="整数"
SolverAdd CellRef:=Cells(r2 + 1, c + 1), Relation:=1, FormulaText:="6000"

SolverSolve

Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).Copy
c = c + 3
Cells(r2 + 1, c - 1).PasteSpecial
Range(Cells(r1, c - 1), Cells(r2, c - 1)).FormulaR1C1 = "=RC[-3]-RC[-2]"

total = Cells(r2 + 1, c - 1)

SolverReset

n = n + 1

Wend

Cells(r2 + 1, c) = n

End Sub

お礼

何度もありがとうございます。
なんとか理解でき、計算もできました。
あと１つお聞きしたいのですが　現在のVBAだと６つの数字？セル？
しかできません。
これを２４個のセル？寸法数がある場合　どこをどうやって改良すればよろしいでしょうか。よろしくお願いします。

回答No.6

okormazd

#4です。
改良版です。
今度は寸法で降順にソートしてください。

Sub solver3()

'寸法で降順にソートしておくこと。

r1 = 2
r2 = 7
c = 3
n = 0

Range(Cells(1, c + 2), Cells(10, 256)).ClearContents
Cells(r2 + 1, c - 1).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"
total = Cells(r2 + 1, c - 1)
SolverReset

rm = r1
nrm = Cells(rm, c - 2)
While nrm = 0
rm = rm + 1
nrm = Cells(rm, c - 2)
Wend
SolverAdd CellRef:=Cells(rm, c), Relation:=3, FormulaText:="1"

While total > 0

Range(Cells(r1, c + 1), Cells(r2, c + 1)).FormulaR1C1 = "=RC1*RC[-1]"
Range(Cells(r1, c), Cells(r2, c)) = 1
Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"

SolverOk SetCell:=Cells(r2 + 1, c + 1), MaxMinVal:=1, ValueOf:=6000, ByChange:=Range(Cells(r1, c), Cells(r2, c))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=1, FormulaText:=Range(Cells(r1, c - 1), Cells(r2, c - 1))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=3, FormulaText:="0"
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=4, FormulaText:="整数"
SolverAdd CellRef:=Cells(r2 + 1, c + 1), Relation:=1, FormulaText:="6000"

SolverSolve

Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).Copy
c = c + 3
Cells(r2 + 1, c - 1).PasteSpecial
Range(Cells(r1, c - 1), Cells(r2, c - 1)).FormulaR1C1 = "=RC[-3]-RC[-2]"

rm = r1
nrm = Cells(rm, c - 2)
While nrm = 0
rm = rm + 1
nrm = Cells(rm, c - 2)
Wend
SolverAdd CellRef:=Cells(rm, c), Relation:=3, FormulaText:="1"

total = Cells(r2 + 1, c - 1)

SolverReset

n = n + 1

Wend

Cells(r2 + 1, c) = n

End Sub

回答No.5

okormazd

#4です。
ちょっと説明不足でした。
元データは本数の多い順でソートしておいてください。
それから、
32のところは本数の合計式(SUM)が入ります。
これを入れないなら、コードに次を追加してください。

Range(Cells(1, c + 2), Cells(10, 256)).ClearContents
追加
Cells(r2 + 1, c - 1).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"

total = Cells(r2 + 1, c - 1)
SolverReset

　A　　　B
寸法　　本数
1250　　7
3100　　6
500　　　6
4000　　5
650　　　5
800　　　3
　　　　32

回答No.4

okormazd

たとえば、下記のように　A2,B2からそれぞれ寸法と本数を入力して、
下のVBAを実行してください。ソルバーを使っています。
1回実行するごとに確認画面が出ますが、確認画面が出なくなるまでOKをクリックしてください。

このコードを実行するには、VBEの参照設定で、SOLVERにチェックを入れる必要があります。
6000mmから半端ができるだけでないように、6000mmの本数ができるだけ少なくなるようになるはずです。完全ではないですが、最適に近い「取寸」が取れるでしょう。

説明が面倒なので、実行結果をよく見て解釈してください。

　A　　　B
寸法　　本数
4000　　5
3100　　6
1250　　7
800　　　3
650　　　5
500　　　6
　　　　32

Sub solver3()

r1 = 2
r2 = 7
c = 3
n = 0

Range(Cells(1, c + 2), Cells(10, 256)).ClearContents

total = Cells(r2 + 1, c - 1)
SolverReset

While total > 0

Range(Cells(r1, c + 1), Cells(r2, c + 1)).FormulaR1C1 = "=RC1*RC[-1]"
Range(Cells(r1, c), Cells(r2, c)) = 1
Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).FormulaR1C1 = "=SUM(R[-6]C:R[-1]C)"

SolverOk SetCell:=Cells(r2 + 1, c + 1), MaxMinVal:=1, ValueOf:=6000, ByChange:=Range(Cells(r1, c), Cells(r2, c))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=1, FormulaText:=Range(Cells(r1, c - 1), Cells(r2, c - 1))
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=3, FormulaText:="0"
SolverAdd CellRef:=Range(Cells(r1, c), Cells(r2, c)), Relation:=4, FormulaText:="整数"
SolverAdd CellRef:=Cells(r2 + 1, c + 1), Relation:=1, FormulaText:="6000"
SolverSolve

Range(Cells(r2 + 1, c - 1), Cells(r2 + 1, c + 1)).Copy
c = c + 3
Cells(r2 + 1, c - 1).PasteSpecial
Range(Cells(r1, c - 1), Cells(r2, c - 1)).FormulaR1C1 = "=RC[-3]-RC[-2]"

total = Cells(r2 + 1, c - 1)

SolverReset

n = n + 1

Wend

Cells(r2 + 1, c) = n

End Sub

お礼

ありがとうございました。
すごく便利でとてもいいのですがマクロボタン１つで表示してくれたら
もっと嬉しいですね。
でもこれを参考にすこし勉強させて頂きます。
ありがとうございました。

回答No.3

n-jun

検索：Ｅｘｃｅｌ　ナップサック
http://www.google.co.jp/search?sourceid=navclient&hl=ja&ie=UTF-8&rlz=1T4GGLG_jaJP310JP310&q=%ef%bc%a5%ef%bd%98%ef%bd%83%ef%bd%85%ef%bd%8c%e3%80%80%e3%83%8a%e3%83%83%e3%83%97%e3%82%b5%e3%83%83%e3%82%af

この辺が参考になるかもです。

お礼

ありがとうございます。
ナップサックの勉強が必要なようです（汗）
もう少し頑張ります。

回答No.2

Hardking

エクセルセル関数かＶＢＡマクロどちらで処理されたいのか
わかりませんが、内容的にエクセルセル関数で事足りるので
エクセルセル関数での一例を下記します。

※とりあえず、明細入力行を最大１０行使用します。
１．セルＡ１～Ａ１０は寸法入力セルとします。
２．セルＢ１～Ｂ１０は本数入力セルとします。
３．セルＣ１～Ｃ１０を各明細毎の小計とします。（寸法×本数）
　　セル式「C1」=A1 * B1
　　セル式「C2」=A2 * B2
（中略）
　　セル式「C10」=A10 * B10

４．セルＣ１１をセルＣ１～Ｃ１０の合計とします。
　　セル式「C11」= SUM(C1:C10)

５．セルＣ１２を合計値を単位鋼材最大長６０００ｍｍで割り
　　更に切上げ処理を行えば、必要本数が自動計算されます。
　　セル式「C12」= ROUNDUP(C11 / 6000 , 0)
以上です。

お礼

ありがとうございます。

回答No.1

nattocurry

ちなみに、例の場合だったら、どのような計算をして、どのような結果になれば良いのでしょうか？

補足

早速ありがとうございます。
例の場合なら
１本が6000mmなので
(1)　・1250mm+1250mm+1250mm
　　・3100mm
　　・4000mm

(2)　・1250mm
　　・3100mm+1250mm
　　・4000mm+1250mm

という組み合わせがあります。
組み合わせは(1)か(2)のどちらか１つでいいのですが
数字を組み合わせて6000mm以内になるように作りたいのです。
その組み合わせを表示させ　何本必要なのかも知りたいのです。
よろしくお願いします。