素数あれこれ

Private Sub cmdEratosthes_Click()
'
' エラトステネスの篩（ふるい）
'
    '-------------------------------
    ' 前処理
    '-------------------------------
    
    cmdCancel.Enabled = True
    
    Application.Calculation = xlCalculationManual   '自動計算オフ
    
    'シート初期化
    
    Columns("C:C").Select
    Range(Selection, Selection.End(xlToRight)).Clear '値クリア
    Range("Count") = ""
    Range("Ratio") = ""
    Range("Time") = ""
    Range("Cal_Count").Select
    
    Dim w() As Integer  '作業用配列
    Dim Nmax As Long    '調査する値の最大値

    Nmax = Val(Range("Cal_Count"))     '検査する数値の最大値
    RowCount = Val(Range("RowCount"))  '1列の表示行数
    
    '-----------------------------------
    ' 入力チェック
    '-----------------------------------
    If Cells.Rows.Count < Nmax Then
        MsgBox "行数がオーバーします！"
        GoTo MyEnd
    ElseIf Cells.Columns.Count < GetCol(Nmax, RowCount, COl_ST) Then
        MsgBox "列数がオーバーします！"
        GoTo MyEnd
    End If
    '-----------------------------------
    
    ReDim w(Nmax)   '作業域確保
    
    
    Dim i As Long, k As Long


    Dim t As Long       '計測タイマ
    t = GetTickCount
    
    '-------------------------------
    ' 素数生成開始
    '-------------------------------
    blCancel = False
    
    Dim Count As Long
    
    w(1) = 1
        
    Count = 0   '素数個数カウンタ
       
    For i = 2 To Nmax
    
        If blCancel Then Exit For   'キャンセル
        
        If w(i) = 0 Then
            
            Count = Count + 1 '素数個数アップ
                    
            For k = 2 To Int(Nmax / i)  '倍数にチェック
                w(i * k) = 1            '非素数：1
            Next k

            Dim R As Long, C As Long    'シート上の行列番号
            R = GetRow(Count, RowCount, COl_ST) '行番号取得
            C = GetCol(Count, RowCount, COl_ST) '列番号取得
            Cells(R, C) = i             '素数を表示

        End If
        
        If (i Mod RowCount) = 0 Or i = Nmax Then
            Range("Progress") = i               '進捗
            DoEvents
        End If
        
    Next i


MyEnd:

    '-------------------------------
    ' 後処理
    '-------------------------------
    Range("Count") = Count                      '素数個数
    Range("Ratio") = Count / Nmax               '比率
    Range("Time") = (GetTickCount - t) / 1000   '所要時間
    
    Application.Calculation = xlCalculationAutomatic    '自動計算オン
    
    cmdCancel.Enabled = False

End Sub

'------------------------------------------------------------------
' 内部関数
'------------------------------------------------------------------

Private Function GetRow(n As Long, RowCount As Long, COl_ST As Long)
'
' 番号からシート内の行番号生成
'
    GetRow = ((n - 1) Mod RowCount) + 1      '行番号
End Function

Private Function GetCol(n As Long, RowCount As Long, COl_ST As Long)
'
' 番号からシート内の列番号生成
'
    GetCol = Int((n - 1) / RowCount) + COl_ST '列番号
End Function 

Function IsPrimeNo(数値) As Boolean
'
' 素数判定
'
' 　方式　：試し割り　3〜SQR(Num)
'
' 　戻り値：TRUE:素数 FALSE:合成数
'
    Dim i As Long
    
    Select Case 数値
        Case 1: IsPrimeNo = False   '１は素数でない
        Case 2: IsPrimeNo = True    '２は素数
        Case Else
            If (数値 Mod 2) = 0 Then    '２で割り切れたら素数でない
                IsPrimeNo = False
            Else
                IsPrimeNo = True
                For i = 3 To Int(Sqr(数値)) Step 2  '３以上の奇数で割ってみる
                    If (数値 Mod i) = 0 Then '割り切れるか・
                        IsPrimeNo = False
                        Exit For   '素数では無い！
                    End If
                Next i
            End If
    End Select

End Function

Function GetPrimeFactors(数値)
'
' 素因数分解:Fatorization
'
    Dim i As Long
    Dim n As Long
    Dim lngQ As Long '商
    Dim lngR As Long '余り
    Dim strRc        '返却値
    
    On Error GoTo MyErr
    
    strRc = ""
    
    n = 数値 '検査する値
    i = 2    '初期因数
    
    Do
        If (n Mod i) = 0 Then
            strRc = strRc & "," & i
            n = n \ i
            i = 2
        Else
            i = i + 1
        End If
    Loop While (i <= Int(Sqr(n))) And (n <> 1)
    
    If n <> 1 Then strRc = strRc & "," & n  '割れ残り

    If Left(strRc, 1) = "," Then strRc = Right(strRc, Len(strRc) - 1) '先頭のカンマを除去
    
    GoTo MyEnd
    
MyErr:
    strRc = CVErr(xlErrValue)
MyEnd:
    On Error GoTo 0
    
    GetPrimeFactors = strRc   '戻り値

End Function

Public Sub Go(Nmax As Long)
'
' ウラム螺旋作成開始
'

    blCancel = False    'キャンセルフラグ初期化
    
    '有効列数チェック
    
    Dim ColCnt As Long
    
    ColCnt = Int((Cells.Columns.Count - 1) / 2) * 2 + 1 '直近奇数
    If Nmax > ColCnt ^ 2 Then
        MsgBox "列数をオーバーします。" & vbCrLf & vbCrLf & _
                Format(ColCnt ^ 2, "###,##0") & "以下にして下さい。"
        Exit Sub
    End If
    
    
    Application.Calculation = xlCalculationManual '自動計算オフ
    Application.EnableEvents = False              'イベントオフ
    lblTime.Caption = ""    '所要時間クリア
    
    Dim t As Long
    t = GetTickCount    '計測開始

    
    Dim i As Long
    Dim n As Long, M As Long
    Dim x As Long, y As Long
    
    Dim w() As Long
    
    ReDim w(Nmax)
    
    
    w(1) = 1
    For n = 2 To Nmax
        If w(n) = 0 Then
            For i = 2 To Int(Nmax / n)
                w(n * i) = 1
            Next i
        End If
    Next n
    
    
    With Sheets("ウラムの螺旋")

        '作業枠幅設定
        ColW = Application.WorksheetFunction.RoundUp(Sqr(Nmax), 0)  '切り上げ
        If (ColW Mod 2) = 0 Then ColW = ColW + 1    '偶数だったら直上の奇数に
        
        'シート初期化
        Call InitSheet_ウラムの螺旋(ColW)
        
        '中心セル座標
        x0 = Int(ColW / 2) + 1
        y0 = Int(ColW / 2) + 1
        .Cells(y0, x0).Select   '選択

        
        M = 1
        n = 0

        .Cells(y0, y0).Interior.Color = vbRed
            
        
        For i = 1 To Nmax
            
            If blCancel Then Exit For   'キャンセルボタンが押された
            
            If (i Mod 1000) = 0 Or i = Nmax Then
                lblProgress.Caption = i & "/" & Nmax    '進行状況
                lblTime.Caption = _
                    Format((GetTickCount - t) / 1000, "#,##0.00秒")  '所要時間
                DoEvents
            End If

           
            If w(i) = 0 Then
                
                n = n + 1
                GetSpiralPos i, x, y
                .Cells(y + y0, x + x0) = i 'セルに数値表示
                .Cells(y + y0, x + x0).Interior.Color = vbCyan
                        
            End If
        
        Next i
       

    End With

    Application.Calculation = xlCalculationAutomatic '自動計算オン
    Application.EnableEvents = True
    


End Sub



Private Function GetSpiralPos(n As Long, ByRef x As Long, ByRef y As Long)
'
' うずまき座標取得　出発点を(0,0)とする相対座標
'
    Dim w As Long    '一辺の長さ
    Dim w2 As Long
    Dim L As Long    '中心から最大相対位置
    Dim P As Long    '完全平方からの不足数
    
    Dim M As Long
    
    '外接する正方形の幅
    M = Application.WorksheetFunction.RoundUp((Sqr(n) + 1) / 2, 0) 
    '
    ' (2m-1)^2 ≦ n　奇数幅の正方形升目数 m:1,2,3・・・
    '
    w = 2 * M - 1   '正方形の幅
    w2 = w - 1      '一辺幅−１
    L = Int(w / 2)
    
    P = w ^ 2 - n   '完全平方からの不足数
    
    Select Case P
    
        Case Is < w2 * 1
            x = L: y = L - P
        Case Is < w2 * 2
            x = L - (P Mod w2): y = -L
        Case Is < w2 * 3
            x = -L: y = (P Mod w2) - L
        Case Is < w2 * 4
            x = (P Mod w2) - L: y = L

    End Select

End Function