• ベストアンサー

エクセルVBAで「コラッツの予想」の検証?

「コラッツの予想」を確かめるため、下記のようなマクロを書いてみました。 コラッツの予想とは「正の整数に対して、偶数なら2で割り、奇数なら3を掛け1を足す。これを繰り返すとやがて1になる。」という未だ証明されてない数学の問題です。 Sub Collatz_test02() Dim x As Double t = Time() With Application .ScreenUpdating = False .Calculation = xlCalculationManual For n = 1 To 10000000 x = n + 1 '.StatusBar = n & "目を処理中です。" 'Cells(n) = x Do While x > 1 If Int(x / 2) = x / 2 Then 'Modは途中でエラー! x = x / 2 Else x = x * 3 + 1 End If Loop Next .StatusBar = "" .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Cells(1 , 1) = Time() - t End Sub 1.セルにいちいち数値をいれたり、進行状況をStatusBarに表示したりしなければ1~1000万までは約8分で終了し、少なくとも1000万までは「予想」は正しいことを実証できましたが、このペースではこれを10億や100億まで試すわけにもいきません。 なにか良い方法はありますでしょうか?数台のPCを使って分散するという方法以外でお願いします。(エクセル2000です) 2.Mod演算子を使うと途中で必ずエラーになります。なぜでしょうか?

質問者が選んだベストアンサー

  • ベストアンサー
  • kinki-u
  • ベストアンサー率11% (1/9)
回答No.1

プログラム自体よりもアルゴリズムの話ですが、すでにチェックを 終えた数値に一旦なれば、そこでその数値の計算を終了するという 一文を入れたらどうでしょうか? つまり、500という数字を検証して いるのならば、499以下の数字になればそこで証明済みなのでストップ させるということです。毎回カウントアップしていけば、すぐに チェックできると思います。 プログラムに明るくありませんので、すでにその機構が上記の プログラムに含まれているのなら失礼しました。

merlionXX
質問者

お礼

なるほど、仰せのとおりです。 下記のように修正したところ、1000万までわずか30秒でした! このペースなら100億にも手が届きそうです。 Sub Collatz_test03() Dim x As Double, n As Double Dim t As Date t = Time() Cells(1, 1) = t With Application .ScreenUpdating = False .Calculation = xlCalculationManual For n = 1 To 10000000 x = n + 1 Do While (1) If Int(x / 2) = x / 2 Then x = x / 2 Else x = x * 3 + 1 End If If x = 1 Then Exit Do If x < n Then Exit Do Loop Next .StatusBar = "" .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Cells(2, 1) = Time() Cells(3, 1) = Time() - t End Sub

merlionXX
質問者

補足

偶数の判定に便利なMOD演算子をつかうと、n=113383で必ずエラーになります。なぜかわかりませんでしょうか?

その他の回答 (2)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

こんばんは。Wendy02です。 私には、むつかしい話は加われませんが、 >2.Mod演算子を使うと途中で必ずエラーになります。なぜでしょうか? >偶数の判定に便利なMOD演算子をつかうと、n=113383で必ずエラーになります。なぜかわかりませんでしょうか? Long 型は、2,147,483,647 が上限ですから、それを越える数値は扱うことが出来ません。たぶん、それを越えて、オーバーフローが起きているのだと思います。Mod の精度の一番上の型は、Long 型です。n がいくらDouble 型でも、Mod の演算で、サイズダウンしますから、Long 型の扱いになります。

merlionXX
質問者

お礼

Wendy02さん、いつもご指導ありがとうございます。 > Mod の精度の一番上の型は、Long 型 そうなんですか?!上限があるなんて存じませんでした。Σ( ̄ロ ̄lll) > Long 型は、2,147,483,647 が上限 それじゃ、2,482,111,348でひっかかるのは当然なんですね。 勉強になりました。<(_ _)>

merlionXX
質問者

補足

100億まで試したところ、6時間弱で終了! 無限ループにならなかったということは100億までは「コラッツの予想」の検証ができたということですよね。できたからと言って得するわけじゃないですけど(笑) ありがとうございました。o(^-^)o

  • kinki-u
  • ベストアンサー率11% (1/9)
回答No.2

ここが参考になりそうです。 (コラッツ予想は、一回とんでもない数字に行ってから帰ってくる こともあるので難しいですね。というかおもしろいですね) http://blog.livedoor.jp/dankogai/archives/50562776.html

参考URL:
http://blog.livedoor.jp/dankogai/archives/50562776.html
merlionXX
質問者

お礼

kinki-uさん、何度もありがとうございます。 御紹介のサイトはVBAではないのでよくわかりませんが、113383が1812855948になってひっかかったようです。 わたしのは120回目で2482111348になってひっかかりました。 If x Mod 2 = 0 Then を If Int(x / 2) = x / 2 Then に変えてやって247回目で1に収束したのですが。 面白いですね。

merlionXX
質問者

補足

昨夜、100億まで試しました。 6時間弱かかりましたが無限ループになりませんでしたので100億までは「コラッツの予想」の検証ができました。できたからと言って別にどうかなるわけじゃないんですが(笑) ありがとうございました。o(^-^)o

関連するQ&A

  • ExcelのVBA動作中の再計算禁止について

    ワークシート上に多数のチェックボックスを設置し、 一括管理のために簡単なVBAを記述しました。 Sub チェックボックス一括TRUE() With Application .ScreenUpdating = False .Calculation = xlCalculationManual CheckBoxes.Value = True .Calculation = xlCalculationAutomatic End With End Sub これだと瞬間で処理が完了するのですが、当初は .Calculation = xlCalculationManual .Calculation = xlCalculationAutomatic の二行をそれぞれ EnableCalculation = False EnableCalculation = True としていて、これは相当遅くなります(後者が遅い)。 速度の違いから両社は明らかに異なる動作をしていると思いますが、 調べてはみたものの自分にはそれぞれの処理の意味がよく理解できていません。 どなたかご教授いただければ。

  • For Nextマクロの高速化についてご教示ください。

    エクセル2000です。 以下は、ワークシートのA列の2行目以降に赤(Interior.ColorIndex = 3 )のセルがあればその行を非表示に、1行目のA列以降に赤いセルがあればその列を非表示にする単純なマクロです。通常はストレスなく動いてくれるのですが、あるBOOKにこのマクロを設定したら、わずか200行程度の処理に1分以上かかってしまいました。 そのBOOKは1.4MBあるのでそのせいとも思えるのですが、それにしても時間がかかりすぎるような気もします。 高速化する方法がありましたらご教示くださいませ。 (o。_。)oペコッ Private Sub 行列非表示() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False With ActiveSheet x = .Cells(1, 1).SpecialCells(xlLastCell).Row y = .Cells(1, 1).SpecialCells(xlLastCell).Column For i = 2 To x If .Cells(i, "A").Interior.ColorIndex = 3 Then .Rows(i).Hidden = True End If Application.StatusBar = i Next i For n = 1 To y If .Cells(1, n).Interior.ColorIndex = 3 Then .Columns(n).Hidden = True End If Application.StatusBar = n Next n End With Application.StatusBar = "" Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Exit Sub End Sub

  • Excel VBA AutoFit の制約について

    お世話になります。 Excel2010(Windows7) VBA にて、セル幅が自動調整 されず表示が「###」のままの場合があるのですが、 Cells.Select: Cells.EntireColumn.AutoFit 実行において何か成約事項等ございますでしょうか? また、次のコードを使用した場合も、自動調整されない 場合もありました(殆どは自動調整されるのですが)。 その際は(記憶が曖昧ですが)「.EnableEvents = False」 をコメントアウトすると自動調整されました。 同一Bookの中でも、ルーチンによって動きが異なります。 With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With ・・・ Cells.Select Cells.EntireColumn.AutoFit ・・・ With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With 情報不足で申し訳ございませんが よろしくお願い申し上げます。

  • エクセルVBA 長さ0の文字列をNullに

    エクセル2000です。 アクセスから出力されたデータをエクセルに貼り付けた場合、問題がおきることがあります。 調べてみたら、アクセスでは、同じ空白でも、レコードが作られてからまだ一回もデータが入っていない状態と、何かデータが入ったことはあるが、削除されて今は空白になった状態をそれぞれ「Null値」と、「長さ 0 の文字列」との 2 種類に区別しているようです。 そのためなのか、それをコピーしてくるとエクセル側でも何もデータが入ってないのに「空白」とはみなされないセルができてしまい、マクロの動きをおかしくしてしまうことがあります。(今日、マクロが想定しない動きをして、その原因がわからず往生しました) やむをえず以下のようなマクロをつくりましたが、Usedrangeが広いとこれもけっこう時間がかかります。 Sub Null化() '長さ0の文字列をNullに   With Application     .ScreenUpdating = False     .Calculation = xlCalculationManual       For Each c In ActiveSheet.UsedRange         If c.Value = "" And Not IsNull(c) Then           c.ClearContents         End If       Next c     .Calculation = xlCalculationAutomatic     .ScreenUpdating = True   End With End Sub 最初から、「長さ 0 の文字列」セルを一度に選択する方法があれば簡単なのですが、そのような方法はありますか? あるいは他のもっとよい方法などがあればご教示くださいませ。  (o。_。)oペコッ

  • VBA 高速化

    以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

  • エクセルVBAでもっと早く転記

    エクセル2000です。 以下は、列をコピーし行にペーストする作業を含むVBAですが、もっとスマートに早く転記する方法がありましたらご教示ください。 お願いします。 Sub TEST() With Application .ScreenUpdating = False .Calculation = xlCalculationManual Sheets("データ").Range("B8:DH8").ClearContents With Sheets("入力") .Range("G8:G68").Copy Sheets("データ").Range("C8:BK8").PasteSpecial Paste:=xlValues, Transpose:=True .Range("G14:G15").Copy Sheets("データ").Range("BM8:BN8").PasteSpecial Paste:=xlValues, Transpose:=True Sheets("データ").Range("BQ8") = .Range("G21") Sheets("データ").Range("BR8") = .Range("G23") .Range("G25:G29").Copy Sheets("データ").Range("BS8:BW8").PasteSpecial Paste:=xlValues, Transpose:=True .Range("G32:G68").Copy Sheets("データ").Range("BX8:DH8").PasteSpecial Paste:=xlValues, Transpose:=True End With Application.CutCopyMode = False .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub

  • エクセルVBAでUsedRange内の可視セルを指定する方法

    UsedRange内の可視セル限定で、ロックされていない場合、データをクリアしたいのです。 以下のようなコードを書いてみましたがSpecialCellsのところでコンパイルエラーになってしまいます。 どのように直せばよいのでしょうか? Sub シートクリア() Application.Calculation = xlCalculationManual Application.EnableEvents = False For Each c In Intersect(SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange) If c.Locked = False Then c.MergeArea.ClearContents End If Next Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

  • EXCEL VBAについて教えてください

    はじめまして。 過去ログに私のやりたいような内容を探していたらこのような下記のエクセルVBAがあったので、教えて頂きたいです。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub If Target.Value = "" Then Exit Sub x = Target.Value With Application .ScreenUpdating = False .EnableEvents = False .Undo y = Target.Value Target.Value = x + y .EnableEvents = True .ScreenUpdating = True End With With Cells(ActiveSheet.Rows.Count, "C").End(xlUp) .Offset(1, 0).Value = x .Offset(1, 1).Value = Time() End With End Sub A1に入力するたびに同一セルに加算。 A1をクリアできる。 C列に入力履歴、D列に入力時間を記録。 If Target.Address <> "$A$1" Then Exit Sub の$A$1を変えることによって他のセルにも設定できる。 と、いう内容なのですが、これをたとえば同一シートのA1~E10のセルとA12~E22にも同じよう別々に処理できるように設定したいのですが、どのようにすればいいのでしょうか?ちなみにA11~E11とA23~E23は合計を表示するセルにしたいです。 Excelのバージョンは2003です。 よろしくお願い致します

  • ▲ExcelのVBA▼困っています

    何度もVBAで質問させてもらい助けてもらっています。 懲りずにまた質問ですが… 下のプログラムは"●"が跳ね返るものなのですが… ●の後を■と▲が追うようなプログラムにするには なにを追加すればいいのでしょうか…?; どなたか教えて下さい;;お願いします;; Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim maru As String, yoko As String, tate As String Sub 描画() Cells(X, Y).Value = maru End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() maru = "●" X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub

  • エクセルVBA実行エラーの対処方法

    以前教えていただいた構文ですが、NOWより過ぎてない日付がFirstRow 31より有り、過ぎた日付がない場合に実行するとエラーが出ます。これを回避するのを教えてください。 宜しくお願いします。 Const DateColumn = "B" '日付が入力されている列 Const FirstRow = 31 '削除の対象となる可能性がある最初の行 Dim LastRow With ActiveSheet LastRow = .Range(DateColumn & Rows.Count).End(xlUp).row If LastRow <= FirstRow Then MsgBox "処理すべきデータがありません。" _ & vbCrLf & "マクロを終了します。" _ , vbExclamation, "データ無し" Exit Sub End If With Application .ScreenUpdating = False .Calculation = xlManual End With .Range(DateColumn & FirstRow - 1 & ":" & DateColumn & LastRow) _ .AutoFilter Field:=1, Criteria1:="<=" & Now, _ Field:=1, Criteria2:="", Operator:=xlOr .Range(DateColumn & FirstRow & ":" & DateColumn & LastRow) _ .SpecialCells(xlCellTypeVisible).EntireRow.Delete .Cells.AutoFilter End With With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With

専門家に質問してみよう