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

マクロ　対話型

変数　知らなかった本当の使い方
Sub kiguu_tyusyutu()’各集計間隔での奇数、偶数出現回数集計
Dim kai As long, i As long, ii As long, r As long, t As long, x As long As long
Dim span As long, owari As long
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 As long, i As long, ii As long, r As long, t As long, x As long, span, owari As long

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 As long, i As long, k As long, retu As long, iti As long, clored As long
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 As long, motosuu As long
Dim i As long, n As long, start As long, x As long
   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 As long, k As long, gyou As long, retu As long
Dim deme As long, ndeme As long, yiti As long
Dim demebar As Object, ndemebar As Object
Dim  tdemebarAs Object, 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 As long, iti As long
Dim gyou As long, retu As long

  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 As long, j As long, i As long, kaigou As long
Dim gyou_deme As long, retu_deme As long
 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 long
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