URL /
Comment
'-----------------------------------------------------------
'■「いわゆる部分和問題」をExcelで解く-(旧８系：打鍵猿系)
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5471068
'
' ◆動作仕様
'
' アクティブシートの
'
' ・A1セルに目標値
' ・B1セル以下に要素
'
' を入力して起動すると
'
' ・A2セルに発見した解の個数
' ・C列以降に解
'
' を書き出します｡
'
' ESC > [はい] でそれまでに見つけた解を書き出します。
'
' ※むろんジョークコードですが、ふつうに思うよりかは当たります。
' ※たいていのケースで、ソルバーよりは速く解を見つけます。
'
'-----------------------------------------------------------
URL /
Comment
'-----------------------------------------------------------
'■k0SSS_8_11
'ボゾサーチ？
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5471068
'
'要素をランダムに選んでフラグを入れ替え、ヒット判定
'たいていのケースで、意外なほど当たります。
'-----------------------------------------------------------
'■親Ｐ-------------------------------------------
Sub k0SSS_8_11()
'●宣言-------------------------------
Dim itmAry() As Long '要素配列
Dim tmpAry() As Boolean '一時配列
Dim rtnAry As Variant '結果配列
Dim dspAry As Variant '書出配列
Dim itmCnt As Long '要素個数
Dim rtnCnt As Long '結果個数
Dim rtnLmt As Long '結果上限
Dim itmIdx As Long '要素番号
Dim rmnSum As Long '残和
Dim endFlg As Boolean '終了フラグ
Dim optCel As Range '目標値設定セル
Dim itmCel As Range '要素範囲上端セル
Dim i As Long
Dim j As Long
Dim k As Long
'●初期処理---------------------------
Set optCel = Range("A1")
Set itmCel = Range("B1")
Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents
optCel.Offset(1, 0).Clear
itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1
rtnLmt = Columns.Count - itmCel.Column
ReDim itmAry(1 To itmCnt)
ReDim tmpAry(1 To itmCnt)
ReDim rtnAry(1 To rtnLmt)
For i = 1 To itmCnt
itmAry(i) = itmCel(i, 1).Value
Next i
Application.ScreenUpdating = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo handleCancel
'●主処理-----------------------------
rmnSum = optCel.Value
Do
itmIdx = Int(Rnd() * itmCnt + 1)
If tmpAry(itmIdx) Then
rmnSum = rmnSum + itmAry(itmIdx)
Else
rmnSum = rmnSum - itmAry(itmIdx)
End If
tmpAry(itmIdx) = Not tmpAry(itmIdx)
If rmnSum = 0 Then
rtnCnt = rtnCnt + 1
rtnAry(rtnCnt) = tmpAry
Application.StatusBar = rtnCnt
endFlg = rtnCnt = rtnLmt
End If
Loop Until endFlg
'●表示-------------------------------
With optCel.Offset(1, 0)
.Value = rtnCnt
.NumberFormatLocal = "0 ""件以上？ ウキキっ"""
End With
ReDim dspAry(1 To itmCnt, 1 To rtnCnt)
For i = 1 To rtnCnt
For j = 1 To itmCnt
If rtnAry(i)(j) Then
dspAry(j, i) = itmAry(j)
End If
Next j
Next i
itmCel.Offset(, 1).Resize(itmCnt, rtnCnt).Value = dspAry
'●終了-------------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
'●キャンセルトラップ-----------------
handleCancel:
If Err.Number = 18 Then
Select Case MsgBox("中止？", 515)
Case vbYes
endFlg = True
Case vbNo
Stop
End Select
Else
On Error GoTo 0
End If
Resume
End Sub
'-----------------------------------------------------------
URL /
Comment
'-----------------------------------------------------------
'■k0SSS_8_01
'ボゴサーチw
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5471068
'
'組み合わせをランダムに選んでヒット判定
'たいていの場合、ソルバーよりかは速いですww
'-----------------------------------------------------------
'■親Ｐ-------------------------------------------
Sub k0SSS_8_01()
'●宣言-------------------------------
Dim tmpAry() As Boolean '一時配列
Dim rtnAry As Variant '結果配列
Dim dspAry As Variant '書出配列
Dim itmCnt As Long '要素個数
Dim rtnCnt As Long '結果個数
Dim rtnLmt As Long '結果上限
Dim tgtSum As Long '目標和
Dim endFlg As Boolean '終了フラグ
Dim optCel As Range '目標値設定セル
Dim itmCel As Range '要素範囲上端セル
Dim tmpCel As Range '残和表示セル
Dim itmRng As Range '要素範囲
Dim tmpRng As Range '作業列
Dim i As Long
Dim j As Long
Dim k As Long
'●初期処理---------------------------
Set optCel = Range("A1")
Set itmCel = Range("B1")
Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents
optCel.Offset(1, 0).Clear
itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1
rtnLmt = Columns.Count - itmCel.Column
tgtSum = optCel.Value
ReDim tmpAry(1 To itmCnt)
ReDim rtnAry(1 To rtnLmt)
Set tmpCel = optCel.Offset(1)
Set itmRng = itmCel.Resize(itmCnt)
Set tmpRng = itmCel.Offset(, 1).Resize(itmCnt)
Application.ScreenUpdating = False
tmpRng.Formula = "=INT(RAND()*2)"
tmpCel.Formula = "=SUMPRODUCT(" & itmRng.Address & "," & tmpRng.Address & ")"
With Application
.Calculation = xlCalculationManual
.EnableCancelKey = xlErrorHandler
End With
On Error GoTo handleCancel
'●主処理-----------------------------
Do
Application.Calculate
If tmpCel.Value = tgtSum Then
rtnCnt = rtnCnt + 1
Application.StatusBar = rtnCnt
rtnAry(rtnCnt) = tmpRng.Value
endFlg = rtnCnt = rtnLmt
End If
Loop Until endFlg
'●表示-------------------------------
With tmpCel
.Value = rtnCnt
.NumberFormatLocal = "0 ""件以上？ ウキっ"""
End With
If rtnCnt > 0 Then
ReDim dspAry(1 To itmCnt, 1 To rtnCnt)
For i = 1 To rtnCnt
For j = 1 To itmCnt
If rtnAry(i)(j, 1) Then
dspAry(j, i) = 1
End If
Next j
Next i
itmCel.Offset(, 1).Resize(itmCnt, rtnCnt).Value = dspAry
itmRng.Copy
tmpRng.Resize(, rtnCnt).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlPasteSpecialOperationMultiply
End If
'●終了-------------------------------
With Application
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
.StatusBar = False
.ScreenUpdating = True
End With
Exit Sub
'●キャンセルトラップ-----------------
handleCancel:
If Err.Number = 18 Then
Select Case MsgBox("中止？", 515)
Case vbYes
endFlg = True
Case vbNo
Stop
End Select
Else
On Error GoTo 0
End If
Resume
End Sub
'-----------------------------------------------------------