趣味のエクセルマクロ

ナンバーズ4などの数字選択式宝くじデータ分析用の自作マクロおよびナンバーズ4の各種データリストなどをブログにしています。

3.N4ST分析

ナンバーズ4のストレート分析

Sub kiguu_tyusyutu()’各集計間隔での奇数、偶数出現回数集計
Dim kai, i, ii, r, t, x, span, owari As Integer
Sheets("ストレートパターン").Select
i = 4
Cells(3, 454) = Empty
kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
If kai = False Or kai = "" Then End
Range("ql4:qt5000,px4:qa5000").ClearContents
owari = Cells(2, 15) + kai
Cells(3, 454) = kai & "回毎"
Call saikeisanoff '再計算を止めて計算を速くする
i = 4
Do Until Cells(i, 4) = ""
  For x = 0 To 3
If Cells(i, 4 + x) / 2 = Int(Cells(i, 4 + x) / 2) Then
     Cells(i, 440 + x) = 0
Else
     Cells(i, 440 + x) = 1
End If
Next x
 i = i + 1
If i > 5000 Then Exit Do
Loop
i = 4
For ii = 0 To owari Step kai
 For r = 0 To 3
       Select Case r '千、百,十,一,のデータ表示列位置の設定
         Case 0: span = 455 '千
         Case 1: span = 457 '百
         Case 2: span = 459 '十
         Case 3: span = 461 '一
        End Select 
  Cells(i, span) = Application.CountIf(Range(Cells(4 + ii, r + 440), Cells(ii + kai + 3, r + 440)), 1)
Cells(i, span + 1) = Application.CountIf(Range(Cells(4 + ii, r + 440), Cells(ii + kai + 3, r + 440)), 0)
Next r
    If ii > 0 Then Cells(i - 1, 454) = ii
    i = i + 1
Next ii
 Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー


Sub 大小_tyusyutu()
Dim kai, i, ii, r, t, x, span, owari As Integer
Sheets("ストレートパターン").Select
i = 4
Cells(3, 474) = Empty
kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
If kai = False Or kai = "" Then End
Range("rf4:rn5000,qc4:qf5000").ClearContents
owari = Cells(2, 15) + kai
Cells(3, 474) = kai & "回毎"
Call saikeisanoff '再計算を止めて計算を速くする
Do Until Cells(i, 4) = ""
For x = 0 To 3
  If Cells(i, 4 + x) < 5 Then
     Cells(i, 445 + x) = 0
  Else
     Cells(i, 445 + x) = 1
  End If
Next x
   i = i + 1
  If i > 5000 Then Exit Do
Loop
i = 4
For ii = 0 To owari Step kai
 For r = 0 To 3
       Select Case r '千、百,十,一,のデータ表示列位置の設定
        Case 0: span = 475 '千
        Case 1: span = 477 '百
        Case 2: span = 479 '十
        Case 3: span = 481 '一
       End Select 
  Cells(i, span) = Application.CountIf(Range(Cells(4 + ii, r + 445), Cells(ii + kai + 3, r + 445)), 1)
Cells(i, span + 1) = Application.CountIf(Range(Cells(4 + ii, r + 445), Cells(ii + kai + 3, r + 445)), 0)
Next r
 If ii > 0 Then Cells(i - 1, 474) = ii
    i = i + 1
Next ii
 Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub de_sort()
    Range("ID15:IH234").Select
ActiveWorkbook.Worksheets("box分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("box分析").Sort.SortFields.Add Key:=Range( _
     "IE15:IE234"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
     xlSortNormal
ActiveWorkbook.Worksheets("box分析").Sort.SortFields.Add Key:=Range( _
     "IG15:IG234"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
     xlSortNormal
With ActiveWorkbook.Worksheets("box分析").Sort
     .SetRange Range("ID15:IH234")
     .Header = xlGuess
     .MatchCase = False
     .Orientation = xlTopToBottom
     .SortMethod = xlPinYin
     .Apply
End With

  If Cells(14, 246) = 0 Then
      Range("ID15:IH41").Select
      Selection.Copy
      Range("IM15").Select
      ActiveSheet.Paste
   End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー


Sub pea_next_box()
Dim j, i, k, retu, iti, clored As Integer
j = 0: i = 4: k = 0: retu = 0
   start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("次数字").Select
Range("gh10:ij10") = Empty
Range("gh12:ik4000").Clear
bangoend = Cells(10, 1)
Range("ga12") = "=LEFT(F12,2)"
Range("gb12") = "=LEFT(F12,1)&MID(F12,3,1)"
Range("gc12") = "=LEFT(F12,1)&RIGHT(F12,1)"
Range("gd12") = "=MID(F12,2,2)"
Range("ge12") = "=MID(F12,2,1)&RIGHT(F12,1)"
Range("gf12") = "=RIGHT(F12,2)"
Range("gg12") = "=F12"
Range("ga12:gg12").Copy Range(Cells(13, 183), Cells(11 + bangoend, 189))
Call saikeisanoff
 i = 12
Do Until Cells(i, 189) = ""
k = 0
For j = 0 To 5 '出目の入力348

d = Cells(i, j + 183).Value
  If d >= 11 And d <= 19 Then
    k = -1
 ElseIf d >= 22 And d <= 29 Then
    k = -3
ElseIf d >= 33 And d <= 39 Then
    k = -6
ElseIf d >= 44 And d <= 49 Then
    k = -10
ElseIf d >= 55 And d <= 59 Then
    k = -15
ElseIf d >= 66 And d <= 69 Then
    k = -21
ElseIf d >= 77 And d <= 79 Then
    k = -28
ElseIf d >= 88 And d <= 89 Then
    k = -36
ElseIf d = 99 Then
    k = -45
Else
    k = 0
End If
    retu = d + 190 + k
   caunter = Application.CountA(Range(Cells(12, retu), Cells(500, retu)))
   Cells(10, retu) = caunter

  iti = 0 '分割後同じ2桁の場合の位置調整
If j = 1 Then
     If Cells(i, j + 182) = Cells(i, j + 183) Then iti = -1
 ElseIf j = 2 Then
     If Cells(i, j + 182) = Cells(i, j + 183) Then iti = -1
 ElseIf j = 3 Then
     If Cells(i, j + 181) = Cells(i, j + 183) Then iti = -1
     If Cells(i, j + 182) = Cells(i, j + 183) Then iti = -1
ElseIf j = 4 Then
     If Cells(i, j + 181) = Cells(i, j + 183) Then iti = -1
     If Cells(i, j + 182) = Cells(i, j + 183) Then iti = -1
ElseIf j = 5 Then
     If Cells(i, j + 182) = Cells(i, j + 183) Then iti = -1
End If   
        Cells(600 + iti + caunter, retu) = Cells(i + 1, 1) '当選回   
        Cells(12 + iti + caunter, retu) = Cells(i + 1, 189) '当選番号
      If caunter = 0 Then
          Cells(1100 + iti + caunter, retu) = Cells(i + 1, 1) '当選間隔
      Else
          Cells(1100 + iti + caunter, retu) = Abs(Cells(600 + iti + caunter, retu) - Cells(599 + iti + caunter, retu))   '当選間隔
          clored = Cells(1100 + iti + caunter, retu)          
         Select Case clored
         Case 0 To 5
           Cells(12 + iti + caunter, retu).Select
           Selection.Font.ColorIndex = 10 '緑4       
           Case 6 To 10
           Cells(12 + iti + caunter, retu).Select
             Selection.Font.ColorIndex = 7
          Case 11 To 29
          Cells(12 + iti + caunter, retu).Select
              Selection.Font.ColorIndex = 1 '黒1
         Case Else
            Cells(12 + iti + caunter, retu).Select
             Selection.Font.ColorIndex = 3 '赤
        End Select    
      End If
Next j
i = i + 1
    If i = 4001 Then Exit Do
Loop
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
 Sub pea_next_box_seiretu()   'tripear_sujiの番号,回号、間隔を下並び出力。
Dim degen_max, motosuu As Integer
Dim i, n, start, x As Integer
   start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("次数字").Select
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
 degen_max = Cells(9, 190)
   Call saikeisanoff '再計算を止めて計算を速くする
For x = 190 To 244
    motosuu = 0
  motosuu = Cells(10, x)
If degen_max > motosuu Then
   Range(Cells(12, x), Cells(motosuu + 1700, x)).Select  '番号,
   Selection.Cut
   Cells(12 + degen_max - motosuu, x).Select
   ActiveSheet.Paste
End If
Next x
Call saikeisanon '再計算を起動させる
End Sub
 Sub deme_st4間隔() 'deme間隔でアンダーバー引く
Dim i, k, gyou, retu, deme, ndeme, yiti  As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Object
Worksheets("ストレートパターン").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
deme = Cells(gyou, retu)
Set demebar = Application.Cells(gyou, retu)
Set ndemebar = Application.Cells(gyou, retu + 4)
  i = 1
 Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1
If i = 2000 Then Exit Do
Loop
If k >= 11 And k <= 29 Then
  demebar.Font.Underline = xlUnderlineStyleSingle
  ndemebar.Font.Underline = xlUnderlineStyleSingle

ElseIf k >= 30 Then
  demebar.Font.Underline = xlUnderlineStyleDouble
  ndemebar.Font.Underline = xlUnderlineStyleDouble

Else
  demebar.Font.Underline = xlUnderlineStyleNone
  ndemebar.Font.Underline = xlUnderlineStyleNone
End If
If k = 0 Then
   Cells(gyou, retu + 4) = 0
Else
   Cells(gyou, retu + 4) = k
End If
   Cells(gyou + 1, retu).Select
deme_st4間隔
'return0

End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
  Sub HotNo_KanakuWriter() 'ホットナンバーの間隔記入予備作業
Dim kankaku_d, iti As Integer
  gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)
If kankaku_d <= 3 Then 'ホット間隔数記入
Cells(17, retu + 133).Select
h = 0
Do Until Cells(17 + h, retu + 133) = ""
     h = h + 1
   Cells(16 + h, retu + 133).Select
     If h = 50 Then Exit Do
Loop
  End
End If
Cells(100, retu + 133).Select 'ホット間隔開始記入準備
i = 0
Do Until Cells(100 + i, retu + 133) = ""
     i = i + 1
     If i = 500 Then Exit Do
Loop
Cells(100 + i, retu + 133).Select
start = MsgBox(kankaku_d & "  間隔はok?", vbYesNo)
   If start = vbYes Then
     Cells(100 + i, retu + 133) = kankaku_d
   Else
     End 
   End If
iti = Cells(15, retu + 133) + 17  
Cells(iti, retu + 133).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub copy_100()
    Range("ID15:IH41").Select
  Selection.Copy
   Range("IM15").Select
  ActiveSheet.Paste
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー



Sub deme_uesita()  ’入力した出目の前後の出目をすべての桁でチェックする
Dim deme, j, i, kaigou, gyou_deme, retu_deme As Integer
 Worksheets("ストレートパターン").Select
kaigou = Cells(2, 15) + 3
Range("TA4:TD5000").Select

Selection.ClearContents
Range(Cells(4, 4), Cells(kaigou, 7)).Select
  Selection.Copy
  Range("SV4").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  deme = Cells(2, 523)
i = 1
  Do Until Cells(3 + i, 519) = ""
    For j = 1 To 4
     If Cells(4 + i, 515 + j) = deme Then  
          Cells(3 + i, 520 + j) = Cells(3 + i, 515 + j)
          Cells(4 + i, 520 + j) = deme
          Cells(5 + i, 520 + j) = Cells(5 + i, 515 + j)        
     End If     
   Next j
        i = i + 1
        If i > 5000 Then Exit Do
  Loop
    Cells(kaigou - 50, 520).Select
 End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ban_gox() '判定番号位置欄に移動する
Dim bango As String
bango = Application.InputBox("小さい順に番号入力して下さい")
start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then Range("P14:IA14").Select: End
'If bango > 99 Or bango < 0 Then MsgBox "データ等をチェックして下さい。": End
 Range("P14:IA14").Select
  Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
      :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
      True, SearchFormat:=False).Activate
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub go_last() '3桁番号のラストに移動する。
Dim idocell As Integer
Sheets("box分析").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
  idocell = Application.CountA(Range(Cells(15, 256), Cells(700, 256))) + 15
Range(Cells(gyou, 247), Cells(gyou, 252)).Select
  Selection.Cut
Cells(idocell, 256).Select
   ActiveSheet.Paste
End Sub