anonymous No title
No License VBA
2020年07月07日
Copy Clone
Option Explicit
Sub 部分和問題()
Range("C:C").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long

'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------


'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = Range("B1").Value
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------


'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------


'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub
'-------------------------------------------------------


outputPoint:
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Perts = WorksheetFunction.Transpose(Perts)
Range("C1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub

Option Explicit
Sub 部分和問題()
Range("C:C").ClearContents
Dim n As Long
Dim a As Variant
Dim i As Long
Dim j As Long

'n個の整数を配列化--------------------------------------
n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim a(n - 1) As Variant
For i = 0 To n - 1
 a(i) = Cells(i + 1, 1)
Next
'-------------------------------------------------------


'求める総和をxに代入しxの大きさの配列pを用意-----------
'p(0) は初期値0 それ以外の要素は初期値-1
Dim x As Long '総和
Dim p As Variant
x = Range("B1").Value
ReDim p(x) As Variant
p(0) = 0
For i = 1 To x
 p(i) = -1
Next
'-------------------------------------------------------


'配列pに部分和を格納していく----------------------------
'p(x)に値が格納され次第「outputPoint」へ飛ぶ
For i = 0 To UBound(a)
 For j = UBound(p) To 0 Step -1
  If p(j) <> -1 And j + a(i) <= x Then
   If p(j + a(i)) = -1 Then
    p(j + a(i)) = a(i)
   End If
   If p(x) <> -1 Then GoTo outputPoint
  End If
 Next j
Next i
'-------------------------------------------------------


'p(x)に値が格納されなかったら解なし
MsgBox "解なし"
Exit Sub
'-------------------------------------------------------


outputPoint:
'outputPoint--------------------------------------------
'配列pに格納された値から部分集合を求める
'方法:
'①P(x)の値が部分集合の一つの値となる
'②次にp(x-p(x))が部分集合の一つの値となる
'以降繰り返してp(x) = x となったら終了
Dim Perts() As Variant
Dim v As Long
Dim cnt As Long
v = x
Do
 ReDim Preserve Perts(cnt) As Variant
 If p(v) = v Then
  Perts(cnt) = v
  Exit Do
 Else
  Perts(cnt) = p(v)
  v = v - p(v)
  cnt = cnt + 1
 End If
Loop
Perts = WorksheetFunction.Transpose(Perts)
Range("C1").Resize(cnt + 1) = Perts
MsgBox "求まりました。"
End Sub

No one still commented. Please first comment.