[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『レシートの金額合計を8万円にしたい』（kiyoko）Windows Vista Excel2007
買い物を行ったレシートがあります。 レシートの合計金額8万円以上で商品券1枚と引き換えができます。
シートの枚数を0～100枚(入力セル：A1～A100)の間として、この合計金額を8万円～8万10円の金額におさめたいと思っています。 A1～A100の金額全てを使用しても、一部分を使用しても構いませんので、8万円～8万10円の金額におさめたいと思っています。 もちろん合計金額8万円ちょうどのほうがお得ですので、8万>8万1円>8万2円>...>8万10円の優先順位で結果を出したいと考えています。 結果は8万円に一番近い金額結果のみを表示したいです。 この結果の表示はA1～A100以外のセルであればどこでも構いません。 その結果と同時に、A1～A100セルの「8万円に一番近い金額結果」の計算に使用したセルの文字を赤色に表示させたいです。 また、8万円～8万10円の間の組み合わせが存在しないときは、「8万円～8万10円の組み合わせは存在しません」と表示させたいです。
どなたかご教授お願い致します。
これは、機械的にやろうと思っても無理でしょうね。 100枚のレシートをしらみつぶしに調べようとしたら、 その組み合わせ総数はとんでもない数字ですから。
30枚なら約10億通りで、このくらいならマクロで出来るでしょうけど。
それとも、100枚の内、何枚以上の組み合わせは 調べなくてもいいというような条件があるのでしょうか？ (それでも10枚制限で194億通り) （純丸）(o^-')b
レシートの金額の範囲は？ 最小 \200 ～ 最大 \5,000 等。 (NB)
Private Sub CommandButton1_Click()
Dim X As Integer, Z As Integer, C As Integer, A As Integer
For A = 1 To 100 '入力されているデータの最後のセルを調べる
If Sheet1.Cells(1, A) = "" Then
A = A - 1
Exit For
End If
Next A
Z = 0
For X = 1 To A '合計を計算
Z = Sheet1.Cells(1, X) + Z
Cells(1, X).Select '文字色を”赤”に変更
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Select Case Z '80000～80010までを調べ、合計を表示
Case Z = 80000
Sheet1.Cells(2, 1) = Z
Case Z = 80001
Sheet1.Cells(2, 1) = Z
Case Z = 80002
Sheet1.Cells(2, 1) = Z
Case Z = 80003
Sheet1.Cells(2, 1) = Z
'
'ｚ＝80010まで書く。 めんどいので自分で同じように書いてね！
'
'
End Select
Next X
If Z < 80000 Then '表示と文字色を戻す
MsgBox " 「8万円～8万10円の組み合わせは存在しません」"
For X = 1 To A
Cells(1, X).Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Next X
End If
If Z > 80000 Then '表示と文字色を戻す
MsgBox " 「8万円～8万10円の組み合わせは存在しません」"
For X = 1 To A
Cells(1, X).Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Next X
End If
End Sub
この例では、毎日１～２枚のレシートをスーパーで買い物をして持ち帰り
その金額をセルに記入していったものを想定しています。
またコマンドボタンをシート上に配置しています。
（犬のしっぽ）
個人用なので、セル位置とかはA1～A100にしていません アンド
8万円～8万10円との事でしたが、設定した金額に一番近いものを出すロジックです。
レシートのリストをD5,D6,D7... のように
設定金額(80000)をB5セルに設定後、下記マクロを動かすボタンでも配置して下さい。
'金額選択マクロ
Dim moneys() As Long '金額リスト
Dim moneySet As Long '設定金額
Dim moneySelect As Long '選択金額合計
Dim moneyTotal As Long '合計金額
Dim money As Long '金額
Dim count As Long '金額リスト数
Dim seq As Long '選択対象となったパターン番号
Dim StartLine As Long
Private Sub CommandButton1_Click()
'金額設定開始行数
StartLine = 5
'設定金額
moneySet = Cells(StartLine, 2).Value
moneyTotal = 0
count = 0
'金額取込
Do While count < 65536
money = Cells(count + StartLine, 4).Value
If money = 0 Then
Exit Do
End If
count = count + 1
ReDim Preserve moneys(count)
moneys(count) = money
moneyTotal = moneyTotal + money
Loop
moneySelect = moneyTotal
'金額算出
For i = 1 To 2 ^ count
money = 0
For j = 1 To count
flg = Application.WorksheetFunction.RoundUp(i / (2 ^ (j - 1)), 0) Mod 2
If flg = 0 Then
money = money + moneys(j)
End If
Next j
'最小値か？
If (moneySet <= money) And (money < moneySelect) Then
moneySelect = money
seq = i
'設定金額そのものなら終了
If moneySet = money Then
Exit For
End If
End If
Next i
'出力
For k = 1 To count
flg = Application.WorksheetFunction.RoundUp(seq / (2 ^ (k - 1)), 0) Mod 2
If flg = 0 Then
Cells(k + StartLine - 1, 4).Interior.ColorIndex = 3
Else
Cells(k + StartLine - 1, 4).Interior.ColorIndex = xlColorIndexNone
End If
Next k
Cells(StartLine + 2, 2).Value = "選択金額合計"
Cells(StartLine + 3, 2).Value = moneySelect
End Sub
(茜たん)
以前に作成した組合せリスト作成サブルーチンで簡単に出来るかなあ と思い、 あれこれ試していたら、既作プログラムに、バグがあることを発見できました。
バグが直せたということで久しぶりにコードの投稿です。
新規ブックにて、
標準モジュール（Module1）に組合せリスト作成プログラム
'=========================================================================
Option Explicit
Private c_svsn As Long '抜き取り数保存
Private c_svsmpn As Long '標本数保存
Private c_idx() As Long '配列のカレントポインタ
Private cs_x() As Long '配列の基盤ポインタ
Private c_eof As Boolean
'=========================================================================
Function init_comb(smpnum As Long, seln As Long) As Double
'組合せ処理ルーチンの初期化
'Input ： smpnum 標本数 seln 抜き取り数
'output : init_comb 組合せ数
Dim g0 As Long
c_svsn = seln
c_svsmpn = smpnum
Erase c_idx()
Erase cs_x()
g0 = 1
ReDim cs_x(1 To seln)
ReDim c_idx(1 To seln)
For g0 = 1 To UBound(c_idx())
cs_x(g0) = g0
c_idx(g0) = g0
Next
c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
init_comb = WorksheetFunction.Combin(smpnum, seln)
c_eof = False
End Function
'=========================================================================
Function get_comb(ans()) As Long
'組合せリストのインデックスを配列として返す
'input : なし
'output: ans() 組合せリストのインデックスを格納する
' get_comb 0:正常に取得 1 リストの終わり
Dim g0 As Long
Dim g1 As Long
get_comb = 1
If c_eof Then Exit Function
For g0 = UBound(c_idx()) To LBound(c_idx()) Step -1
If c_idx(g0) + 1 <= c_svsmpn - c_svsn + g0 Then
c_idx(g0) = c_idx(g0) + 1
get_comb = 0
Exit For
Else
c_idx(g0) = cs_x(g0) + 1
cs_x(g0) = cs_x(g0) + 1
For g1 = g0 + 1 To UBound(cs_x())
cs_x(g1) = cs_x(g1 - 1) + 1
c_idx(g1) = cs_x(g1)
Next g1
End If
Next
If get_comb = 0 Then
For g0 = LBound(c_idx()) To UBound(c_idx())
ans(g0) = c_idx(g0)
Next
Else
c_eof = True
End If
End Function
'=========================================================================
Sub close_comb()
'組合せ処理ルーチンの終了処理
Erase c_idx()
Erase cs_x()
End Sub
'=========================================================================
Function skip_comb(i_num As Long, ans() As Variant) As Long
'指定したインデックスを一つ増加させる
'input: i_num:増加させるインデックス
'output: ans()組合せリストのインデックスを格納する
' skip_comb 0:正常に取得 1 リストの終わり
'組合せリストのインデックスを配列として返す
'input : なし
'output: ans() 組合せリストのインデックスを格納する
' get_comb 0:正常に取得 1 リストの終わり
Dim g0 As Long
Dim g1 As Long
skip_comb = 1
g1 = c_svsmpn
If c_eof Then Exit Function
For g0 = UBound(c_idx()) To i_num + 1 Step -1
c_idx(g0) = g1
g1 = g1 - 1
Next
skip_comb = get_comb(ans())
End Function
別の標準のジュール（Module2）に上記のコードを呼び出して、レシートの計算をする メインプログラム等及び、サンプルデータ作成プログラム
'==========================================================
Sub main1()
Dim Tdata As Variant
Dim rng As Range
Dim snum As Long
Dim nuki As Long
Dim 解 As Long
Dim g0 As Long
Dim g1 As Long
Dim g2 As Long
Dim ret As Long
Dim asum As Long
Dim tm As Double
Dim Mret As Long
Dim bestsum As Long
Dim inttm As Variant
With Columns(3)
.ClearContents
.ColumnWidth = 32
.Interior.ColorIndex = xlNone
End With
解 = 80000
解 = Application.InputBox("目標値を入力してください", , 解, , , , , 1)
If 解 = 0 Then
解 = 80000
End If
Call mk_sample
inttm = Application.InputBox("確認インターバルをhh:mm:ss形式で指定してください", , "00:05:00", , , , , 2)
If TypeName(inttm) = "Boolean" Then
inttm = "00:05:00"
End If
tm = [now()]
Mret = vbOK
Range("a:b").Interior.ColorIndex = xlNone
Set rng = Range("a1", Cells(Rows.count, "a").End(xlUp)).Resize(, 2)
rng.Sort Key1:=Range("b1"), Order1:=xlDescending, Header:=xlNo
Set rng = rng.Columns(2)
Tdata = Application.Transpose(rng.Value)
snum = UBound(Tdata)
asum = 0
For g0 = UBound(Tdata) To LBound(Tdata) Step -1
asum = asum + Tdata(g0)
If asum > 解 + 10 Then
snum = UBound(Tdata) - g0
Exit For
End If
Next
bestsum = 解 + 100
For g0 = 1 To snum
Call init_comb(UBound(Tdata), g0)
ReDim ans(1 To g0)
ret = get_comb(ans())
Do While ret = 0
asum = 0
For g1 = LBound(ans()) To UBound(ans())
asum = asum + Tdata(ans(g1))
If asum > 解 + 10 Then Exit For
Next
nuki = g1
If nuki >= UBound(ans()) Then
If asum < 解 Then
nuki = chk_seq(ans())
Debug.Print nuki & " :" & asum
If nuki > 0 Then
ret = skip_comb(nuki, ans())
Else
Exit Do
End If
Else
If asum >= 解 And asum <= 解 + 10 Then
If asum < bestsum Then
Range("a:c").Interior.ColorIndex = xlNone
For g1 = LBound(ans()) To UBound(ans())
rng.Cells(ans(g1)).Offset(0, -1).Resize(, 2).Interior.ColorIndex = 4
Next
Cells(g2 + 1, 3).Interior.ColorIndex = 4
bestsum = asum
End If
Cells(g2 + 1, 3).Value = UBound(ans()) & "件 合計 : " & asum
g2 = g2 + 1
tm = [now()]
If asum = 解 Then
Mret = vbCancel
Exit Do
End If
End If
ret = get_comb(ans())
End If
Else
ret = skip_comb(nuki, ans())
End If
If [now()] - tm > TimeValue(inttm) Then
Mret = MsgBox("抜き出し " & g0 & "件 実行中 続けますか?", vbOKCancel)
tm = [now()]
If Mret = vbCancel Then Exit Do
End If
Loop
Call close_comb
If Mret = vbCancel Then Exit For
Next
Set rng = Range("a1", Cells(Rows.count, "a").End(xlUp)).Resize(, 2)
rng.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlNo
Set rng = Nothing
Erase ans()
Erase Tdata
End Sub
'=======================================================
Sub mk_sample()
With Range("a1:b100")
.Formula = Array("=row()", "=int(rand()*5000)+1")
.Value = .Value
.Interior.ColorIndex = xlNone
End With
End Sub
'========================================================
Function chk_seq(ans()) As Long
chk_seq = 0
Dim g0 As Long
For g0 = UBound(ans()) To LBound(ans()) + 1 Step -1
If ans(g0) <> ans(g0 - 1) + 1 Then
chk_seq = g0 - 1
Exit For
End If
Next
End Function
まっさらなシートをアクティブにしてmain1を実行してみてください。
まず、目標値を入力します。規定値で80000と入力されています。そのままでよければ、 ＯＫボタンです。
次にサンプルデータがa1:b100に作成されます。
Ａ列は、連番、Ｂ列にランダムな数値、すなわち、レシートの金額になります。
サンプルデータに習って実際には、データを作成してください。
御自分でデータを作成するときは、main1内の
Call mk_sample は、コメント化すること。
次に 確認メッセージを出す間隔をhh:mm:ss形式で入力します。
規定値で 00:05:00 つまり、5分が設定されています。このままでよければ、ＯＫボタンをクリックです。
これで検索開始です。
Ｃ列に 合計値とレシート枚数が表示されます。 目標値に最も近いリストに色が付けられます。
目標値～目標値＋10が見つからず、インタ-バル時間（上記の例だと5分）を過ぎると、続行・中止を選択するメッセージは 表示されますから、処理が長い場合、オペレータが判断してください。
目標値ぴったりの値とリストが見つかれば、その時点で処理は、終わりになります。
ichinose
プログラムの訂正投稿tです
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.