[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数の数字の合計』（MATT）
はじめまして。早速ですが以下の内容よろしくお願いします。 近所のガソリンスタンドでこのような特典があります。 「ガソリン150リットル分のレシートで５００円の商品券プレゼント」 そこで質問ですが、たまりにたまったレシートの給油量を入力し、150リットル以上で なおかつ、150リットルに限りなく近くなるレシートの組み合わせを計算式または関数 で簡単に出来ないでしょうか？ 例えば、A**リットル、B**リットル、C**リットル、D**リットル、E**リットル、F**リットルの場合、 A+C=151リットル、B+D=151.5リットルみたいな計算を簡単にしたいのです。 うまく説明できませんが、よろしくお願いします。
EXCEL2002 WIN XPです。
こんな関数はどうでっか？
Alt+F11でVBEを開く
「挿入」→「標準モジュール」を選択
真新しいモジュールに下のコードをコピペ
エクセルに戻り
A B C D E
1 85リットル 98リットル 69.5リットル 92リットル 70リットル
2
3
と、まあ、こんな具合にデータを配置し、F1あたりに=matt(a1:e1)と入力してみて
おくんなはれ。
どうでっか、こんな塩梅で？
（弥太郎）
Function matt(adrs As Range)
Dim x As Double, i As Integer, n As Integer
Dim data As Double, s_data As Double, tbl As Range, y(2)
Set tbl = adrs
x = 500
For i = 1 To tbl.Columns.Count
data = Val(StrConv(tbl(1, i), vbNarrow))
For n = i + 1 To tbl.Columns.Count
s_data = Val(StrConv(tbl(1, n), vbNarrow))
If data + s_data >= 150 Then
If data + s_data - 150 < x Then
x = data + s_data - 150
y(0) = tbl(1, i).Address(0, 0)
y(1) = tbl(1, n).Address(0, 0)
End If
End If
Next n
Next i
matt = x + 150 & "," & y(0) & "と" & y(1)
End Function
2回給油分の組み合わせですか？？？ 3回分４回分等の組み合わせも有るのでしょうか？？？ (JJ)
A B 3回分４回分等の組み合わせも有るのでしょうか？ 1 1 70 2 2 75 3 3 83 4 4 90 5 5 76 6 6 88 7 7 84 8 8 92 9 9 68 10 10 70 11 11 77 12 12 56 13 13 68 14 14 91 15 15 87 16 17 15回給油したとして 18 =COMBIN(15,2)＝105の内一番近い数字を選ぶ（２回のみの組み合わせ）
19 =COMBIN(15,3)＝455の内一番近い数字を選ぶ（3回のみの組み合わせ）
20 =COMBIN(15,4)＝1365の内一番近い数字を選ぶ（4回のみの組み合わせ）
の内一番近い数字を選ぶになりますが
jj
質問内容からすると n枚のレシートからm（1≦m≦n）枚取り出してその合計が150以上で 最小値になる組み合わせを求めるということでしょうか。 実際は、求めた組み合わせのデータを除いた中から同じように 抽出を繰り返すのでしょう。 （やっちん）
な〜るほろ〜。
いかにもありそうでんなぁ。
ほならこないな事でっしゃろか？
=mattaku(a1:j1,3) っちゅう塩梅に入力。抽出されたセルのデータを消去していく。
組合せ４までですけど、それ以上あるばやいはコードの規則性に従って書き加えてく
らはい。
=mattaku(a1:j1)と引数を省略したら２回の組合せで抽出します。
（弥太郎）
Function mattaku(adrs As Range, Optional mai = 2)
Dim x As Double, i As Integer, n As Integer, t As Integer, j As Integer
Dim data1 As Double, data2 As Double, data3 As Double, data4 As Double, tbl As Range, y(3)
Set tbl = adrs
x = 1000
With tbl
Select Case mai
Case 4
For i = 1 To .Columns.Count - 3
If tbl(1, i) <> "" Then
data1 = Val(StrConv(tbl(1, i), vbNarrow))
For n = i + 1 To .Columns.Count - 2
If tbl(1, n) <> "" Then
data2 = data1 + Val(StrConv(tbl(1, n), vbNarrow))
For j = n + 1 To tbl.Columns.Count - 1
If tbl(1, j) <> "" Then
data3 = data2 + Val(StrConv(tbl(1, j), vbNarrow))
For t = j + 1 To tbl.Columns.Count
If tbl(1, t) <> "" Then
data4 = data3 + Val(StrConv(tbl(1, t), vbNarrow))
If data4 >= 150 Then
If data4 - 150 < x Then
x = data4 - 150
y(0) = tbl(1, i).Address(0, 0)
y(1) = tbl(1, n).Address(0, 0)
y(2) = tbl(1, j).Address(0, 0)
y(3) = tbl(1, t).Address(0, 0)
End If
End If
End If
Next t
End If
Next j
End If
Next n
End If
Next i
mattaku = x + 150 & "は" & Join(y, ",")
Exit Function
Case 3
For i = 1 To .Columns.Count - 2
If tbl(1, i) <> "" Then
data1 = Val(StrConv(tbl(1, i), vbNarrow))
For n = i + 1 To .Columns.Count - 1
If tbl(1, n) <> "" Then
data2 = data1 + Val(StrConv(tbl(1, n), vbNarrow))
For j = n + 1 To .Columns.Count
If tbl(1, j) <> "" Then
data3 = data2 + Val(StrConv(tbl(1, j), vbNarrow))
If data3 >= 150 Then
If data3 - 150 < x Then
x = data3 - 150
y(0) = tbl(1, i).Address(0, 0)
y(1) = tbl(1, n).Address(0, 0)
y(2) = tbl(1, j).Address(0, 0)
End If
End If
End If
Next j
End If
Next n
End If
Next i
mattaku = x + 150 & "," & y(0) & "と" & y(1) & "と" & y(2)
Exit Function
Case 2
For i = 1 To .Columns.Count - 1
If tbl(1, i) <> "" Then
data1 = Val(StrConv(tbl(1, i), vbNarrow))
For n = i + 1 To .Columns.Count
If tbl(1, n) <> "" Then
data2 = data1 + Val(StrConv(tbl(1, n), vbNarrow))
If data2 >= 150 Then
If data2 - 150 < x Then
x = data2 - 150
y(0) = tbl(1, i).Address(0, 0)
y(1) = tbl(1, n).Address(0, 0)
End If
End If
End If
Next n
End If
Next i
End Select
If y(0) = "" Then Exit Function
mattaku = x + 150 & "," & y(0) & "と" & y(1)
End With
End Function
A1:A15 の範囲に（上から順に間を明かさず｝リットル数を書き込んで、 下記のマクロを実行してみて下さい。 （純丸）(o^-')b もっと配列の扱いがすっきり出来るんだろうなぁw
Sub test2()
Dim tbl1, tbl2
Dim i As Long
Dim ii As Integer
Dim datacnt As Long
Dim myans As Single
Dim myans2 As Single
Dim myans3 As Long
datacnt = Application.WorksheetFunction.Count(Range("A1:A15"))
Range("A1:A15").Font.ColorIndex = 0
ReDim tbl1(1 To datacnt)
ReDim tbl2(1 To datacnt)
myans = 150
For i = 1 To datacnt
tbl1(i) = Cells(i, 1).Value
Next i
For i = 1 To 2 ^ datacnt
For ii = 1 To datacnt
tbl2(ii) = Int(i / (2 ^ (ii - 1))) Mod 2
myans2 = myans2 + tbl1(ii) * tbl2(ii)
Next ii
myans2 = myans2 - 150
If myans2 < 0 Then GoTo mynext
If myans > myans2 Then
myans = myans2
myans3 = i
End If
mynext:
myans2 = 0
Next i
For ii = 1 To datacnt
If Int(myans3 / (2 ^ (ii - 1))) Mod 2 = 1 Then
Cells(ii, 1).Font.ColorIndex = 3
End If
Next ii
Range("A17").Value = Application.WorksheetFunction.RoundDown(myans, 1) + 150
End Sub
本当に正しいのか怪しいのですが(^^; 無駄な動きをしている部分もありますが、とりあえず。 A列に連番、B列に数値だけのデータを入力。C列は必ずクリアしておいてください。 A列とB列をB列昇順に並び替えます。 ここでTestを実行してください。 D列に合計、E列に組み合わせの番号が出ます。
Dim Min_Pt As String Dim Min_Sm As Double Dim MyArray As Variant Dim MaxRow As Long Const LMT150 = 150#
Sub Test()
Dim Cnt As Long
Dim MyArray2 As Variant
Dim j As Long
Cnt = 0
MyArray = Range(Range("A1"), Range("B" & Rows.Count).End(xlUp).Offset(, 1))
MaxRow = UBound(MyArray, 1)
Do
Cnt = Cnt + 1
Min_Sm = 9999999999999#
Min_Pt = ""
Call Kumiawase(0, 0, "", False)
If Min_Pt <> "" Then
Cells(Cnt, 4).Value = Min_Sm
Cells(Cnt, 5).Value = Mid(Min_Pt, 2)
MyArray2 = Split(Mid(Min_Pt, 2), ",")
For j = 0 To UBound(MyArray2, 1)
MyArray(Application.Match(Val(MyArray2(j)), Columns(1), 0), 3) = 1
Next
End If
Loop Until Min_Pt = ""
End Sub
Sub Kumiawase(ByVal i As Long, ByVal Sm As Double, ByVal Pt As String, ByRef Flg As Boolean)
Dim wk As Long
If Sm >= LMT150 Then
If Min_Sm > Sm Then
Min_Pt = Pt
Min_Sm = Sm
End If
Flg = True
Exit Sub
End If
Do While i < MaxRow
wk = ix(i + 1)
If wk <= MaxRow Then
Call Kumiawase(wk, Sm + MyArray(wk, 2), Pt & "," & MyArray(wk, 1), Flg)
If Flg = True Then
Flg = False
Exit Sub
End If
End If
i = ix(i + 1)
Loop
End Sub
Function ix(ByVal i As Long) As Long
ix = i
Do While ix <= MaxRow
If MyArray(ix, 3) <> 1 Then
Exit Function
End If
ix = ix + 1
Loop
End Function
（やっちん）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.