趣味のエクセルマクロ&数字選択式宝くじ

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

1.N4ST分析


'ナンバーズ4のストレート分析
Dim hit_m(4000, 4) As String
 Dim hitx(4000, 4) As Integer
 Dim hit(4000, 4) As Integer
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub saikeisanoff()'再計算オフと画面変更オフ
With Application
 .Calculation = xlManual
 .MaxChange = 0.001
 End With
 ActiveWorkbook.PrecisionAsDisplayed = False
 Application.ScreenUpdating = False '画面変更をしない。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub saikeisanon()'再計算オンと画面変更オン
With Application
 .Calculation = xlAutomatic
 .MaxChange = 0.001
End With
 ActiveWorkbook.PrecisionAsDisplayed = True
 Application.ScreenUpdating = True '画面変更
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー


'40パターン
Sub patapata_40() '当選数字ストレートパターン貼付け
Dim hitx(6000, 4), i, j, k, l, m, n, t As Integer
 Sheets("ストレートパターン").Select
   saikeisanoff
Erase hitx: i = 0: j = 0
i = 4
Do Until Cells(i, 3) = ""
For j = 1 To 4
     Select Case j
         Case 1: span = 1
         Case 2: span = 11
         Case 3: span = 21
         Case 4: span = 31
   End Select
      hitx(i - 3, j) = Cells(i, j + 3) + span
Next j
   i = i + 1
  k = i
 If i = 5000 Then Exit Do
Loop
  m = 0: l = 0
For l = 1 To k - 4
 For m = 1 To 4
       Cells(l + 3, 15 + hitx(l, m)) = "●"  
 Next m
If l >= 2 Then
 For n = 1 To 40
    If Cells(l + 2, 15 + n) <> "●" And Cells(l + 3, 15 + n) = "●" Then 
        t = t + Cells(l + 2, 15 + n)
        Cells(3 + l, 56) = t
        Cells(3 + l, 57) = t / 4 
     End If
  Next n
     t = 0
 End If

Next l
      saikeisanon
Call 入力
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub cunters() '飛び期間を記入する
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Worksheets("ストレートパターン").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
i = 0
Do Until Cells(gyou + i, retu - 1) = "" And Cells(gyou + i, retu) = ""
  If Cells(gyou + i, retu) = "" Then
       Cells(gyou + i, retu) = k + 1
      k = k + 1
     If Cells(gyou + i + 1, retu) <> "" Then k = 0
  End If
  If i = 4001 Then Exit Do
  i = i + 1
Loop
  If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub plascunt()
Dim p_0 As Integer
  retu = ActiveCell.Column
gyou = ActiveCell.Row
p_0 = Cells(gyou, retu)
Cells(gyou + 1, retu) = p_0 + 1
End Sub
---------------------------------------------------
Sub 横詰め並べ()          
retu = ActiveCell.Column
gyou = ActiveCell.Row           
kijyun = Cells(1, 1)
gejyun = Cells(gyou, 1)
Range(Cells(gyou, 3), Cells(gyou, gejyun + 2)).Select
Selection.Cut

Cells(gyou, kijyun - gejyun + 2).Select
ActiveSheet.Paste
Cells(gyou + 1, 3).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去() '飛び期間の空行を詰めて表示する。
retu = ActiveCell.Column
gyou = ActiveCell.Row
Dim x, i, k As Integer
Sheets("ストレートパターン").Select
Range("BJ6:CW6").Select
Selection.Copy
Range("BJ7:CW4500").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
  Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 Range("db4:eo800").ClearContents
 saikeisanoff
For x = 1 To 40
   i = 0: k = 0
  Do Until Cells(4 + i, 3) = ""
    If Cells(4 + i, 61 + x) <> "" Then
       Cells(4 + i - k, 105 + x).Value = Cells(4 + i, 61 + x).Value
    Else
       k = k + 1
    End If
        If i = 5000 Then Exit Do
     i = i + 1
  Loop
Next x
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
saikeisanon
Cells(gyou, retu).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去_2() '飛び期間の空行を詰めて表示する。
Dim x, i, k As Integer
Sheets("ストレートパターン").Select
Range("db4:eo5000").ClearContents
 saikeisanoff
For x = 1 To 40
i = 0: k = 0
Do Until Cells(4 + i, 3) = ""
  If Cells(4 + i, 15 + x) = "●" Then
      If i = 0 Then
          Cells(4 + i - k, 105 + x).Value = 0
  ElseIf i > 0 Then
        If Cells(3 + i, 15 + x) <> "●" Then
           Cells(4 + i - k, 105 + x).Value = Cells(3 + i, 15 + x).Value
         Else
           Cells(4 + i - k, 105 + x).Value = 0
        End If
   End If  
  Else
     k = k + 1
  End If
              If i = 5000 Then Exit Do
    i = i + 1
Loop
Next x
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空白除去()
retu = ActiveCell.Column
gyou = ActiveCell.Row
t_w = 44
i = 0: k = 0
Do Until Cells(gyou + i, 1) = ""
  If Cells(gyou + i, retu) <> "" Then
       Cells(gyou + i - k, retu + t_w) = Cells(gyou + i, retu)
 Else
      k = k + 1
End If

     If i = 5000 Then Exit Do
     i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 飛び記入() '記入する行をクリックした後マクロ実行する。
gyou = ActiveCell.Row
Call saikeisanoff
If gyou <= 3 Or Cells(gyou, 16) <> "" Then End
For i = 1 To 40
   If Cells(gyou - 1, 15 + i) = "●" Then
     Cells(gyou, 15 + i) = 1
  Else
    Cells(gyou, 15 + i) = Cells(gyou - 1, 15 + i) + 1
 End If
Next i
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー


Sub 飛び記入_4() '記入する行をクリックした後マクロ実行する。
 retu = ActiveCell.Column
 gyou = ActiveCell.Row
For i = 1 To 40
  If Cells(gyou - 1, 15 + i) = "●" Then   '前回●なら今回1、でなければ+1する。
    If Cells(gyou, 15 + i) = "" Then Cells(gyou, 15 + i) = 1
  Else
    If Cells(gyou, 15 + i) = "" Then Cells(gyou, 15 + i) = Cells(gyou - 1, 15 + i) + 1
  End If
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 休み期間() '行をクリックした後マクロ実行する。
gyou = ActiveCell.Row
 Range(Cells(gyou, 16), Cells(gyou, 55)).Select
Selection.Copy
Sheets("飛び計").Select
Range("P2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("P12:P41").Select
Application.CutCopyMode = False
Selection.Cut
Range("Q2").Select
ActiveSheet.Paste
Range("Q12:Q31").Select
Selection.Cut
Range("R2").Select
ActiveSheet.Paste
Range("R12:R21").Select
Selection.Cut
Range("S2").Select
ActiveSheet.Paste
Sheets("ストレートパターン").Select
Range("M2").Select
Selection.Copy
Sheets("飛び計").Select
Range("T1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("ストレートパターン").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 多重当選カウント()
retu = ActiveCell.Column
gyou = ActiveCell.Row
t_w = 44
 i = 0: k = 0
Do Until Cells(gyou + i, retu) = ""  
 If Cells(gyou + i, retu) = "●" Then
  k = k + 1
  kk = k
Else
 Cells(gyou + i + k - 1, retu + 2) = Empty
 Cells(gyou + i, retu + 2) = kk
 k = 0
End If

 If i = 4001 Then Exit Do
   i = i + 1
Loop
  If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub tajyuu()
Sheets("多重当選").Select
Range("P51:BC56").Select
Selection.Copy
  Range("S4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
Sub rencunters()
retu = ActiveCell.Column
gyou = ActiveCell.Row
Call saikeisanoff
i = 0
Do Until Cells(gyou + i, retu) = ""
  If Cells(gyou + i, retu) <> 0 Then
       Cells(gyou + i, retu + 1) = k + 1
      k = k + 1
     If Cells(gyou + i + 1, retu) = 0 Then
        rentyan = k: k = 0
  Cells(gyou + i - 1, retu + 2) = rentyan
  End If
End If
 If i = 4001 Then Exit Do
      i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ido_inp()
Dim atai As Integer
Sheets("多重当選").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
If gyou < 55 Or gyou > 70 Then End
atai = Cells(61, retu)
If atai = 0 Then End
  i = 0
Do Until Cells(gyou + i, retu) = ""
   Cells(gyou + i + 1, retu).Select
If i = 4001 Then Exit Do
   i = i + 1
Loop
  start = MsgBox("okしますか?", vbYesNo)
If start = vbYes Then '値記入する
  Cells(gyou + i, retu) = atai * -1
  Cells(gyou, retu).Select
Else
  Cells(61, retu).Select
End If
End Sub
-----------------------------------------------
Sub 多重整列()
start = MsgBox("整列開始しますか?", vbYesNo)
Dim maxdara, i, motosuu As Integer
If start = vbNo Then End
Sheets("多重当選").Select
Range("P64:BC506").Select
Selection.Copy
    Range("BJ64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
    maxdata = Cells(65, 1)
For i = 62 To 101
   motosuu = Cells(64, i)
   Range(Cells(66, i), Cells(66 + motosuu, i)).Select  '番号
   Selection.Cut
   Cells(66 + maxdata - motosuu, i).Select
   ActiveSheet.Paste
Next i
  Cells(66 + maxdata, 81).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 回go()
ActiveWindow.LargeScroll Down:=3
ActiveWindow.SmallScroll Down:=17
Range("O104").Select
End Sub
Sub kanngo()
 ActiveWindow.ScrollRow = 236
ActiveWindow.SmallScroll Down:=42
Range("O289").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Public patan As Integer
Dim bango As String
--------------------------------------------
Sub testbagen()
For i = 1 To 3000
 Range(Cells(i, 1), Cells(i, 1)).Select
 If Cells(i, 1) = "" Then Exit For
   Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  Cells(i, 1) = "●"
   i = i + 1
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub three_keta4() 'ストレート順での3桁出現回号表示(全4000データ)
three_keta千百十 'サブプログラム three_keta千百十
three_keta千百一 'サブプログラム three_keta千百一
three_keta千十一
three_keta百十一
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百十() 'ストレート順での3桁出現回号表示
Dim i, bangoend As Integer
    Sheets("三桁分析").Select
Range("j28:alu62").Clear
bangoend = Sheets("ストレートパターン").Cells(2, 15)
saikeisanoff
setretu = 0
i = 4
  Do Until Sheets("ストレートパターン").Cells(i, 3) = ""
   setretu = Val(Sheets("ストレートパターン").Cells(i, 4) & Sheets("ストレートパターン"). _
   Cells(i, 5) & Sheets("ストレートパターン").Cells(i, 6)) 
  caunter = Application.Count(Range(Cells(28, 10 + setretu), Cells(45, 10 + setretu)))
    Cells(28 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 1)
    Cells(47 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 3)
    Cells(26, 10 + setretu) = caunter + 1
  If Sheets("ストレートパターン").Cells(i, 1) = bangoend Then
     saikeisanon
     Cells(27, 10 + setretu).Select
  End If
    i = i + 1
  If i = bangoend + 50 Then Exit Do
Loop
  Cells(14, 1) = Cells(24, ActiveCell.Column)
  Cells(15, 1) = Cells(17, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百一() 'ストレート順での3桁出現回号表示
Dim i, bangoend As Integer
    Sheets("三桁分析").Select
Range("j64:alu99").Clear
   bangoend = Sheets("ストレートパターン").Cells(2, 15)
     saikeisanoff
setretu = 0
   i = 4
 Do Until Sheets("ストレートパターン").Cells(i, 3) = ""
setretu = Val(Sheets("ストレートパターン").Cells(i, 4) & Sheets("ストレートパターン"). _
  Cells(i, 5) & Sheets("ストレートパターン").Cells(i, 7))
    caunter = Application.Count(Range(Cells(64, 10 + setretu), Cells(81, 10 + setretu)))

  Cells(64 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 1)
  Cells(83 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 3)
  Cells(63, 10 + setretu) = caunter + 1
      If Sheets("ストレートパターン").Cells(i, 1) = bangoend Then
         saikeisanon

        Cells(27, 10 + setretu).Select
     End If
    i = i + 1
 If i = bangoend + 50 Then Exit Do
Loop
  Cells(16, 1) = Cells(24, ActiveCell.Column)
  Cells(17, 1) = Cells(18, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Sheets("三桁分析").Select
Range("j101:alu136").Clear
  bangoend = Sheets("ストレートパターン").Cells(2, 15)
 setretu = 0
i = 4
Do Until Sheets("ストレートパターン").Cells(i, 3) = ""
        setretu = Val(Sheets("ストレートパターン").Cells(i, 4) & Sheets("ストレートパターン"). _
  Cells(i, 6) & Sheets("ストレートパターン").Cells(i, 7))
 caunter = Application.Count(Range(Cells(101, 10 + setretu), Cells(119, 10 + setretu)))

 Cells(101 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 1)
 Cells(120 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 3)
 Cells(100, 10 + setretu) = caunter + 1

 If Sheets("ストレートパターン").Cells(i, 1) = bangoend Then
 saikeisanon
 Cells(27, 10 + setretu).Select
End If
 i = i + 1
 If i = bangoend + 50 Then Exit Do
Loop
Cells(18, 1) = Cells(24, ActiveCell.Column)
Cells(19, 1) = Cells(19, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta百十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Sheets("三桁分析").Select
Range("j138:alu173").Clear
  bangoend = Sheets("ストレートパターン").Cells(2, 15)
 setretu = 0
i = 4
Do Until Sheets("ストレートパターン").Cells(i, 3) = ""
         setretu = Val(Sheets("ストレートパターン").Cells(i, 5) & Sheets("ストレートパターン"). _
    Cells(i, 6) & Sheets("ストレートパターン").Cells(i, 7))
    Cells(20, 1) = Cells(i, 5)
caunter = Application.Count(Range(Cells(138, 10 + setretu), Cells(156, 10 + setretu)))
 Cells(138 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 1)
 Cells(157 + caunter, 10 + setretu) = Sheets("ストレートパターン").Cells(i, 3)
 Cells(137, 10 + setretu) = caunter + 1
       If Sheets("ストレートパターン").Cells(i, 1) = bangoend Then
     saikeisanon 
     Cells(27, 10 + setretu).Select 
   End If
 i = i + 1
 If i = bangoend + 50 Then Exit Do
Loop
Cells(20, 1) = Cells(24, ActiveCell.Column)
Cells(21, 1) = Cells(20, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_kensaku()
UserForm2.Show 'ユーザーホームを開く
Sheets("三桁分析").Select
On Error GoTo errorcheck
Range("j24:alu24").Select
bango = Application.InputBox("3桁番号入力して下さい")
If bango = "" Then End
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
retu = ActiveCell.Column: gyou = ActiveCell.Row
Cells(10, 1) = patan
Cells(gyou + patan, retu).Select
    Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub st番号1110表示() 'ストレート番号表示する。
saikeisanoff
Worksheets("ストレートパターン").Range("C4:C4000").Copy
Sheets("三桁分析").Select
Range("ALW28").Select
ActiveSheet.Paste
For j = 1 To 1000
  i = 1
Do Until Cells(27 + i, 9 + j) = ""
If Cells(27 + i, 9 + j) <> "" Then
 bango = Cells(27 + i, 9 + j)
 Cells(27 + i, 9 + j) = Cells(27 + bango, 1011)
End If
   i = i + 1
If i = 15 Then Exit Do
Loop
 Next j
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Range("j28:alu42").Clear
bangoend = Application.CountA(Range("ストレートパターン!$C$4:$C$4000"))
 setretu = 0
i = 28
Do Until Cells(i, 1) = bangoend + 1
For j = 2 To 5
setretu = Cells(i, j).Value
Select Case j 'データ表示列位置の設定
    Case 2
        span = 28
    Case 3
        span = 46
    Case 4
        span = 64
    Case 5
        span = 90
End Select

caunter = Application.Count(Range(Cells(28, 10 + setretu), Cells(42, 10 + setretu)))
Cells(28 + caunter, 10 + setretu) = Cells(i, 1)
Cells(26, 10 + setretu) = caunter + 1
Next j
i = i + 1
If Cells(i, 1) = bangoend + 1 Then Cells(27, 10 + setretu).Select
If i = 4000 Then Exit Do
Loop
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub next4number() '次数字を表示する
On Error GoTo errorcheck
Call saikeisanoff '再計算を止めて計算を速くする・
Dim nenum(4) As String, stopnum As Integer
Call saikeisanon
bangoend = Sheets("ストレートパターン").Cells(2, 15)
Range("b12") = "=ストレートパターン!D4&ストレートパターン!D5"
Range("c12") = "=ストレートパターン!E4&ストレートパターン!E5"
Range("d12") = "=ストレートパターン!F4&ストレートパターン!F5"
Range("e12") = "=ストレートパターン!G4&ストレートパターン!G5"
Range("f12") = "=SMALL(ストレートパターン!D4:G4,1)&SMALL(ストレートパターン!D4:G4,2)&SMALL(ストレートパターン!D4:G4,3)&SMALL(ストレートパターン!D4:G4,4)"
Range("b12:f12").Copy Range(Cells(13, 2), Cells(bangoend + 11, 6))
Range(Cells(13, 2), Cells(bangoend + 11, 6)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
kaigo = Application.InputBox("開始回号番号入力して下さい")
If kaigo <= 0 Then End
kaigo = kaigo + 10
Range(Cells(kaigo, 7), Cells(kaigo + 4000, 106)).Select
Selection.ClearContents
  With Selection.Interior
   .Pattern = xlNone
   .TintAndShade = 0
   .PatternTintAndShade = 0
End With
stopnum = Cells(10, 1) + 1
 i = kaigo '12
  Call saikeisanoff
Do Until Cells(i, 1) = Cells(10, 1) + 1
 For n = 1 To 4 '百十一に分ける。
  setretu = Cells(i, 1 + n).Value '番号によりデータ記入位置を設定する。
  Cells(i, setretu + 7) = Cells(i, 1 + n)
  nenum(n) = Cells(i, 1 + n)
 If n = 1 Then
    Cells(i, setretu + 7).Select
   With Selection.Font
 .Color = -16776961
   Selection.Font.Bold = True 
 End With
 ElseIf n = 2 Then
   Cells(i, setretu + 7).Select
With Selection.Font
.Color = -11489280

End With
If nenum(n - 1) = nenum(n) Then
  With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
Selection.Font.Underline = xlUnderlineStyleDouble
  End With
End If
ElseIf n = 3 Then
   Cells(i, setretu + 7).Select
With Selection.Font
  .ThemeColor = xlThemeColorAccent6
   Selection.Font.Underline = xlUnderlineStyleDouble
End With
If nenum(n - 1) = nenum(n) Or nenum(n - 2) = nenum(n) Then
  With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
  Selection.Font.Underline = xlUnderlineStyleDouble
  End With
End If
Else
    Cells(i, setretu + 7).Select
With Selection.Font
  .Color = 2
  Selection.Font.Underline = xlUnderlineStyleSingle
End With
If nenum(n - 3) = nenum(n) Or nenum(n - 2) = nenum(n) Or nenum(n - 1) = nenum(n) Then
  With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
  End With
End If

End If
Next n
i = i + 1
If i = stopnum + 10 Then Exit Do
Loop
 Call saikeisanon '再計算をオンにする
Exit Sub
errorcheck:
MsgBox ("ありません。チェックして下さい"): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub kankaku_cunters()
retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
For i = 1 To 777
 If Cells(gyou + i, retu) = "" Then
  j = j + 1
 Else
  Exit For
 End If
Next i
MsgBox "間隔は " & (j)
If i = 999 Then End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー    
Sub 入力()
jp = Cells(2, 15)
Cells(jp + 4, 3).Select
End Sub
Sub 入力赤丸()
Dim maruiti As Object
Sheets("ストレートパターン").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
Cells(gyou + 1, retu).Select
         j = 1
If Cells(gyou + j, retu) <> "●" Then
  Do Until Cells(gyou + j, retu) = "●"
   If j > 3 Then Exit Do
   j = j + 1
Loop
End If
Cells(gyou + j, retu).Select
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.Color = -16776961
End Sub






3.ナンバーズ4パターン表作成関係エクセルマクロ(3)

Sub kiguu間隔() '奇遇表示と奇偶間隔でアンダーバー引く  ( 16パターンの間隔)
Dim i, k, gyou, kiguu As Integer
Dim kiguin As String
Dim kiguubar, diguubar As Range
Worksheets("パターン表").Select
gyou = ActiveCell.Row
If ActiveCell.Column <> 82 Then End
kiguu = Cells(gyou, 82)’奇遇パターン
Set dkiguubar = Application.Cells(gyou, 26)
Set kiguubar = Application.Cells(gyou, 82)
 i = 1
Do Until kiguu = Cells(gyou - i, 82) ’間隔計算する 
  i = i + 1
  k = i - 1
 If i = 3000 Then Exit Do
Loop
If k < 17 Then'出現間隔が16回以下の時 下線無
    kiguubar.Font.Underline = xlUnderlineStyleNone
   dkiguubar.Font.Underline = xlUnderlineStyleNone
ElseIf k >= 17 And k < 32 Then'出現間隔が17回以上31回以下の時 下線有り
    kiguubar.Font.Underline = xlUnderlineStyleSingle
   dkiguubar.Font.Underline = xlUnderlineStyleSingle
Else '出現間隔が32回以上の時 二重下線にする
  kiguubar.Font.Underline = xlUnderlineStyleDouble
  dkiguubar.Font.Underline = xlUnderlineStyleDouble
End If
Select Case kiguu
 Case 1:  kiguin = "△△△△"
 Case 2:  kiguin = "▲▲▲▲"
 Case 3:  kiguin = "△△△▲"
 Case 4:  kiguin = "△△▲△"
 Case 5:  kiguin = "△▲△△"
 Case 6:  kiguin = "▲△△△"
 Case 7:  kiguin = "▲▲▲△"
 Case 8:  kiguin = "▲▲△▲"
 Case 9:  kiguin = "▲△▲▲"
 Case 10:  kiguin = "△▲▲▲"
 Case 11:  kiguin = "△△▲▲"
 Case 12:  kiguin = "△▲△▲"
 Case 13:  kiguin = "△▲▲△"
 Case 14:  kiguin = "▲▲△△"
 Case 15:  kiguin = "▲△▲△"
 Case 16:  kiguin = "▲△△▲"
End Select
 Cells(gyou, 81) = kiguin’奇遇表示
 ' kiguu間隔
End Sub
--------------------------------------------------------------------------------------------------------


Sub daisyo間隔() '大小間隔でアンダーバー引く(16パターンでの確率で)
Dim i, k, gyou, daisyo As Integer
Dim daisyobar, ndaisyobar As Range
Dim daisy As String
Worksheets("パターン表").Select
gyou = ActiveCell.Row
If ActiveCell.Column <> 34 Then End
daisyo = Cells(gyou, 34)
Set daisyobar = Application.Cells(gyou, 34)
Set ndaisyobar = Application.Cells(gyou, 79)
   i = 1
Do Until daisyo = Cells(gyou - i, 34)
  i = i + 1
  k = i - 1
 If i = 3000 Then Exit Do
Loop
If k < 17 Then’(出現間隔が16回以内の場合)
  daisyobar.Font.Underline = xlUnderlineStyleNone
  ndaisyobar.Font.Underline = xlUnderlineStyleNone
ElseIf k >= 17 And k <= 32 Then
  daisyobar.Font.Underline = xlUnderlineStyleSingle
  ndaisyobar.Font.Underline = xlUnderlineStyleSingle
Else
 daisyobar.Font.Underline = xlUnderlineStyleDouble
 ndaisyobar.Font.Underline = xlUnderlineStyleDouble
End If
If daisyo = 1 Or daisyo = 0 Then
 daisy = "□□□□"
ElseIf daisyo = 2 Then
 daisy = "■■■■"
ElseIf daisyo > 2 And daisyo < 7 Then
 daisy = "■□□□"
ElseIf daisyo > 6 And daisyo < 11 Then
 daisy = "■■■□"
ElseIf daisyo > 10 Then
 daisy = "■■□□"
End If
 Cells(gyou, 79) = daisy
'daisyo間隔
End Sub
--------------------------------------------------------------------------
Sub hotno_copy()
gocel = Cells(1, 2) + 10
Sheets("パターン表").Select
Range("R2:U5000").Select
Selection.Copy
Sheets("欠け算並び").Select
Range("eh10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(gocel, 138).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub stpear_suji()   'ペアストレート数字千百、千十、千一,百十、百一、十一に別に回号、間隔、番号を出力。
Dim j, k, i, n, caunter, maxx, setretu, span, writretu As Integer
 Sheets("23桁").Select
 kaigo = Cells(1, 5)
Call saikeisanoff '再計算を止めて計算を速くする・
caunter = 0
  Range("BXL4:EAE5000").Select '出力表示部のクリア
Selection.ClearContents
Application.ScreenUpdating = False '画面変更をしない。
i = 4
Do Until Cells(i, 1892) = "" And Cells(i, 1897) = ""
For n = 1 To 6 '千百、千十、千一,百十、百一、十一に分ける。
setretu = Cells(i, 1892 + n).Value '番号によりデータ記入位置を設定する。
      Select Case n '千百、千十、千一,百十,百一,十一のデータ表示列位置の設定
   Case 1: span = 1988 '千百
  Case 2: span = 2113 '千十
  Case 3: span = 2238 '千一
  Case 4: span = 2363 '百十
  Case 5: span = 2488 '百一
Case 6: span = 2613 '十一
End Select
writretu = setretu + span
caunter = Application.CountA(Range(Cells(4, writretu), Cells(70, writretu)))    '記入位   置をカウンタから計算する。
  Cells(4 + caunter, writretu) = Cells(i, 15)    '番号データを4行から記入する。
Cells(100 + caunter, writretu) = Cells(i, 1899)   '回号データを記入する。
Cells(1, writretu) = kaigo - Cells(i, 1899)
If caunter = 0 Then '回号データの間隔を200行から記入する
Cells(200 + caunter, writretu) = Cells(i, 1899)
Else
Cells(200 + caunter, writretu) = Abs(Cells(99 + caunter, writretu) - Cells(100 + caunter, writretu))
End If
Cells(2, writretu) = caunter + 1   '合計カウンタを計算し2行目に表示する
  Cells(2, span - 1) = Application.Max(Range(Cells(2, span), Cells(2, span + 100)))
 Next n
i = i + 1
If i = 5000 Then Exit Do
Loop
Application.ScreenUpdating = True '画面変更。
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub TKGM4_seiretu()   'stpear_sujiの番号,回号、間隔を下並び出力。
Dim degen_max, motosuu As Integer
Dim i, n, start As Integer
If Cells(4, 1988) = "" Then End
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("23桁").Select
Application.ScreenUpdating = False '画面変更をしない。
Call saikeisanoff '再計算を止めて計算を速くする・
For n = 1 To 6 '千百、千十、千一,百十、百一、十一に分ける。


      Select Case n '千百、千十、千一,百十,百一,十一のデータ表示列位置の設定
  Case 1: span = 1988 '千百
  Case 2: span = 2113 '千十
  Case 3: span = 2238 '千一
Case 4: span = 2363 '百十
Case 5: span = 2488 '百一
Case 6: span = 2613 '十一
End Select
motosuu = 0
For i = 0 To 99
degen_max = Cells(2, span - 1)
motosuu = Cells(2, i + span)
    Range(Cells(4, i + span), Cells(222 + motosuu, i + span)).Select '番号,
Selection.Cut
Cells(4 + degen_max - motosuu, i + span).Select
ActiveSheet.Paste
Next i
Next n
Call saikeisanon '再計算を起動させる
Application.ScreenUpdating = True '画面変更on。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub 出目集計() '最終回から10回~1000回分を遡って集計
Dim lastkai As Integer
Dim s As Range
saikeisanoff
Worksheets("順位裏復活").Select
  lastkai = Cells(1, 113) + 1 '最終回
Set s = Worksheets("パターン表")
For i = 0 To 9 ’出目0~9迄
’シート順位裏復活の7行目の115列から124列までに
’シートパターン表の最終回から10回分を出目毎に集計する。

   Cells(7, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 9, 18), s.Cells(lastkai, 21)), i) '10回分
   For j = 1 To 4 ’4桁分
Cells(j + 9, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 29, 17 + j), s.Cells(lastkai, 17 + j)), i) '30回分
Cells(j + 16, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 49, 17 + j), s.Cells(lastkai, 17 + j)), i) '50回分              
Cells(j + 23, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 99, 17 + j), s.Cells(lastkai, 17 + j)), i) '100回分
Cells(j + 30, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 199, 17 + j), s.Cells(lastkai, 17 + j)), i) '200回分
Cells(j + 37, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 499, 17 + j), s.Cells(lastkai, 17 + j)), i) '500回分
  Cells(j + 44, 115 + i) = Application.CountIf(s. _
Range(s.Cells(lastkai - 999, 17 + j), s.Cells(lastkai, 17 + j)), i) '1000回分
Next j
Next i
Range("DK2:DT6").Select
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
 Sub box_move() 'box間移動
Dim i, k, gyou, gyounext, nextgyou As Integer
Dim boxspan As String
Worksheets("パターン表").Select
  gyou = ActiveCell.Row
  boxspan = Cells(gyou, 83)
  If ActiveCell.Column <> 83 Then End
If Cells(gyou, 84) = 1 Then End
   nextgyou = Application.CountIf(Range(Cells(gyou, 83), Cells(gyou - 200, 83)), boxspan)
If nextgyou = 1 Then
gyou = gyou - 200
Else
gyou = gyou - 1
End If
  i = 1
Do Until boxspan = Cells(gyou - i, 83)
i = i + 1
Cells(gyou - i, 83).Select
If ActiveCell.Row = 3 Then Exit Do
Loop
Application.ScreenUpdating = True '画面変更。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub rl_lin_edrow() '右下に線を引く(目視でスライド確認して)
Dim retu_frg As Integer
    retu = ActiveCell.Column
   gyou = ActiveCell.Row 
  With Selection.Borders(xlDiagonalDown)
       .LineStyle = xlDot
       .Color = -16738048
       .TintAndShade = 0
       .Weight = xlThin
   End With  
   If Cells(gyou + 1, retu + 1) <> "" Then
     If retu > 75 Then retu = 67: Cells(gyou + 1, retu).Select: End
     Cells(gyou + 1, retu + 1).Select  
     rl_lin_edrow  
  End If 
     If retu >= 56 And retu <= 65 Then retu_frg = 1
     If retu >= 67 And retu <= 75 Then retu_frg = 2
     If retu_frg <> 0 Then Cells(gyou + 1, retu + 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーー
Sub lr_line_drow()

’左下に線を引く(目視でスライド確認して)
    retu = ActiveCell.Column
   gyou = ActiveCell.Row  
  If retu <= 55 Or retu >= 77 Or retu = 66 Then End  
   If retu >= 67 And retu <= 76 Then retu_f = 1
   If retu >= 56 And retu <= 65 Then retu_f = 2  
   With Selection.Borders(xlDiagonalUp)
       .LineStyle = xlDot
       .Color = -16738048
       .TintAndShade = 0
       .Weight = xlThin
   End With  
  If Cells(gyou + 1, retu - 1) <> "" Then 
    If retu_f = 1 Then
     If retu = 67 Then retu = 76: Cells(gyou + 1, retu).Select: End
   ElseIf retu_f = 2 Then
    If retu = 56 Then retu = 65: Cells(gyou + 1, retu).Select: End 
   End If
    Cells(gyou + 1, retu - 1).Select  
    lr_line_drow  
  End If
      Cells(gyou + 1, retu - 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub rk_lin_edrow() '強弱順位で右下に線を引く
Dim retu_frg As Integer
    retu = ActiveCell.Column
   gyou = ActiveCell.Row
   With Selection.Borders(xlDiagonalDown)
       .LineStyle = xlDot
       .Color = -16738048
       .TintAndShade = 0
       .Weight = xlThin
   End With  
   If Cells(gyou + 1, retu + 1) <> "" Then
      If retu > 64 Then retu = 56: Cells(gyou + 1, retu).Select: End
      Cells(gyou + 1, retu + 1).Select  
     rk_lin_edrow  
  End If 
    If retu >= 56 And retu <= 65 Then retu_frg = 1
    If retu >= 67 And retu <= 75 Then retu_frg = 2
    If retu_frg <> 0 Then Cells(gyou + 1, retu + 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub lk_line_drow()
’強弱順位で左下に線を引く
 retu = ActiveCell.Column
   gyou = ActiveCell.Row
   With Selection.Borders(xlDiagonalUp)
       .LineStyle = xlDot
       .Color = -16738048
       .TintAndShade = 0
       .Weight = xlThin
   End With  
  If Cells(gyou + 1, retu - 1) <> "" Then
    If retu = 56 Then retu = 65: Cells(gyou + 1, retu).Select: End
    Cells(gyou + 1, retu - 1).Select  
         lk_line_drow  
    End If
      Cells(gyou + 1, retu - 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hotnum_color()
 Dim maruiti As Range
 Dim gyou, retu, yiti As Integer
  Dim demebar, ndemebar, tdemebar, demerenbar As Object
Worksheets("パターン表").Select
Application.ScreenUpdating = False '画面変更をしない。
   gyou = ActiveCell.Row
   retu = ActiveCell.Column
   If retu <= 17 Or retu >= 22 Then End 
 deme__iti = Cells(gyou, retu) + 67
   deme = Cells(gyou, retu) '出目
If Cells(gyou, retu) > 4 Then
   With Selection.Interior     
       .Color = 65535    
   End With
Else
     With Selection.Interior   
       .Color = 10092543   
   End With  
End If
  Set maruiti = Application.Cells(gyou, deme__iti)  
   maruiti.Font.Underline = xlUnderlineStyleSingle
   maruiti.Font.ColorIndex = 53  
  yiti = deme - Cells(gyou, 85) '出目の位置
Cells(gyou + yiti, retu + 70).Select '桁別に88行から出目対応して上下に
    With Selection.Interior
       .Color = 10092543
    End With   
    Sheets("欠け算並び").Cells(gyou + 8, retu + 125) = Worksheets("パターン表").Cells(gyou, retu)
    Worksheets("パターン表").Select   
    Application.ScreenUpdating = True '画面変更をしない。
    Cells(gyou + 1, retu).Select
 End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_pear_total_kai()   'ペア数字集計
Dim xx, ii, i, kai, owari As Integer
Sheets("23桁").Select
Call all_hyouji
i = 4
Range("ace4:aeh6334").Select
Selection.ClearContents
Cells(3, 759) = Empty
 kai = Application.InputBox("集計間隔を入力して下さい", Default:=9)
 start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End
    Sheets("23桁").Select
    Cells(3, 759) = kai
 Call saikeisanoff
    owari = Cells(1, 1) + kai
For xx = 0 To 54
 For ii = 0 To owari Step kai
  Cells(i, 760 + xx) = Application.CountA(Range(Cells(4 + ii, 681 + xx), Cells(ii + kai + 3, 681 + xx)))
  If ii > 0 Then Cells(i - 1, 759) = ii
 i = i + 1
 Next ii
     i = 4
Next xx
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub all_hyouji()
Columns("BXL:BZL").Select
Selection.EntireColumn.Hidden = False
End Sub
Sub all_hyouji_kai()
Columns("acg:aeh").Select
Selection.EntireColumn.Hidden = False
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub rencunters() '連荘パターン集計
    retu = ActiveCell.Column
    gyou = ActiveCell.Row
  Call saikeisanoff
    i = 0
  Do Until Cells(gyou + i, retu) = ""
      If Cells(gyou + i, retu) <> 0 Then
              Cells(gyou + i, retu + 1) = k + 1
              k = k + 1
          If Cells(gyou + i + 1, retu) = 0 Then
             rentyan = k: k = 0
             Cells(gyou + i, retu + 2) = rentyan '連荘合計
          End If
     End If
    If i = 6000 Then Exit Do
       i = i + 1  
 Loop
        If i = 0 Then MsgBox "データ等をチェックして下さい。": End
    Call saikeisanon
  End Sub
______________________________________________________________________



2.ナンバーズ4パターン表作成関係エクセルマクロ(2)


 Sub s_b_copy() ’上の表の右端と同じデータ(box番号)を探し下端コピーする
 Dim gyou As Integer
Sheets("欠け算並び").Select
gyou = Cells(1, 2) + 1
 saikeisanon
Range("b9") = "=VALUE(パターン表!Q3)"
Range("c9") = "=VLOOKUP(B9,$E$8:$I$10011,5,0)"
Range("d9") = "=VLOOKUP(B9,$E$8:$I$10011,3,0)"
Range("b9:d9").Copy Range(Cells(10, 2), Cells(gyou, 4))
Range(Cells(10, 2), Cells(gyou, 4)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 saikeisanoff
Sheets("パターン表").Select
Range(Cells(2, 17), Cells(gyou, 17)).Select
Selection.Copy
Sheets("欠け算並び").Select
Range("J8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("z8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("パターン表").Select
Range(Cells(2, 83), Cells(gyou, 83)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("欠け算並び").Select
  Range("BT8").Select
ActiveSheet.Paste
saikeisanon
Cells(gyou + 6, 72).Select
 Call kakezancopy ’マクロkakezancopy実行する
End Sub
--------------------------------------------------------------------------------------------------------
Sub kakezancopy()
 Dim i, k, gyou As Integer
 Dim boxspan As String
 Sheets("欠け算並び").Select
 gyou = ActiveCell.Row
 If ActiveCell.Column <> 72 Then End
 If Cells(gyou, 72) = 0 Then End
   boxspan = Cells(gyou, 72)
 Application.ScreenUpdating = False '画面変更をしない。処理速度上げるため。
  i = 1
Do Until boxspan = Cells(gyou - i, 72) ’上の行に向かって同じ番号を探す
 i = i + 1
 If i = 4000 Then Exit Do
Loop
 Range(Cells(gyou - i, 11), Cells(gyou - i, 23)).Select
 Selection.Copy
 Cells(gyou, 11).Select
 ActiveSheet.Paste
 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
 Range(Cells(gyou - i, 27), Cells(gyou - i, 71)).Select
 Selection.Copy’欠け算表をコピー
 Cells(gyou, 27).Select
   Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
 Range(Cells(gyou - i, 89), Cells(gyou - i, 95)).Select
 Selection.Copy
 Cells(gyou, 89).Select
 Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
 Cells(gyou - i, 72).Select
 Selection.Copy
 Cells(gyou, 72).Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
 Application.ScreenUpdating = True '画面変更。
 Cells(gyou, 72).Select
End Sub
--------------------------------------------------------------------------------------------------------
Sub kankaku_sain() '太字と下線を引く
Dim maruiti As Range
Sheets("23桁").Select
 retu = ActiveCell.Column
 gyou = ActiveCell.Row
 san_keta = Cells(gyou, retu)
For i = 1 To 28
 If Cells(gyou, i + 15) = san_keta Then Exit For
Next i
 Set maruiti = Application.Cells(gyou, i + 15)
  maruiti.Font.Underline = xlUnderlineStyleSingle
  maruiti.Font.Bold = True
End Sub
--------------------------------------------------------------------------------------------------------
Sub ban_go3x() '判定番号位置欄に移動する
  Dim bango As String
bango = Application.InputBox("小さい順に番号入力して下さい")
start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then Range("jk3:jj3").Select: End
Range("jl3:rw3").Select
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False).Activate
End Sub
--------------------------------------------------------------------------------------------------------
Sub GO_2桁()
   ActiveWindow.ScrollColumn = 557
Range("UQ2").Select
End Sub
ーーーーーーーーーーーーーーー
Sub 欠け算並びへ()
Sheets("欠け算並び").Select
jp = Cells(1, 2) + 7
Cells(jp, 2).Select
End Sub
ーーーーーーーーーーーーーーーー
Sub 順位裏復活へ()
Sheets("順位裏復活").Select
End Sub
---------------------------------------
Sub n23桁へ()
Sheets("23桁").Select
End Sub
ーーーーーーーーーーーーーーーー
Sub パターン表へ()
Sheets("パターン表").Select
End Sub
--------------------------------------------------------------------------------------------------------
Sub pear_suujikai()   'ペア数字
Dim j, i, k, retu As Integer
   j = 0
  i = 4
  k = 0
retu = 0
Sheets("23桁").Select
Range("a4:a6000").Copy
Range("yv4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
   patann = 0
        Call saikeisanon
     kaigo = Cells(1, 1) + 5
Range("ze4:abg6000").ClearContents
Range("yw4") = "=LEFT(B4,1)&MID(B4,2,1)"
Range("yx4") = "=LEFT(B4,1)&MID(B4,3,1)"
Range("yy4") = "=LEFT(B4,1)&MID(B4,4,1)"
Range("yz4") = "=MID(B4,2,1)&MID(B4,3,1)"
Range("za4") = "=MID(B4,2,1)&MID(B4,4,1)"
Range("zb4") = "=MID(B4,3,1)&MID(B4,4,1)"
Range("yw4:zb4").Copy Range(Cells(5, 673), Cells(kaigo, 678))
     Call saikeisanoff
   UserForm4.Show 'ユーザーホームを開く
Do Until Cells(i, 673) = ""
   For j = 1 To 6 '出目の入力348
      d = Cells(i, j + 672).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 + 681 + k
If patann = 1 Then
   Cells(i, retu) = Cells(i, 15)
ElseIf patann = 2 Then
  Cells(i, retu) = Cells(i, j + 672)
ElseIf patann = 3 Then
  Cells(i, retu) = Cells(i, 672)
End If
Next j
   i = i + 1
  If i = 6000 Then Exit Do
Loop
Call saikeisanon
End Sub
---------------------------------------------------------------------------------------------------------
Private Sub CommandButton3_Click()
If patann = 0 Then MsgBox ("選択して下さい"): Exit Sub
Unload UserForm4 'ユーザーホーム4を閉じる
End Sub
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then patann = 1
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then patann = 2
End Sub
Private Sub OptionButton3_Click()
If OptionButton3.Value = True Then patann = 3
End Sub
---------------------------------------------------------------------------------------------------------
Sub box_pear_total()   'ペア数字集計
Dim xx, ii, i, kai, owari As Integer
Sheets("23桁").Select
Call all_hyouji
i = 4
Range("BXj4:BZM6334").Select
Selection.ClearContents
Cells(3, 1986) = Empty
kai = Application.InputBox("集計間隔を入力して下さい", Default:=9)
Sheets("23桁").Select
Cells(3, 1986) = kai
Call saikeisanoff
owari = Cells(1, 1) + kai
For xx = 0 To 54
For ii = 0 To owari Step kai
  Cells(i, 1987 + xx) = Application.CountA(Range(Cells(4 + ii, 1908 + xx), Cells(ii + kai + 3, 1908 + xx)))
 If ii > 0 Then Cells(i - 1, 1986) = ii
i = i + 1
Next ii
i = 4
Next xx
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_pear_total_kai()   'ペア数字集計
Dim xx, ii, i, kai, owari As Integer
Sheets("23桁").Select
Call all_hyouji
i = 4
Range("ace4:aeh6334").Select
Selection.ClearContents
Cells(3, 759) = Empty 'ace3
kai = Application.InputBox("集計間隔を入力して下さい", Default:=9)
start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("23桁").Select
Cells(3, 759) = kai 'ace3
Call saikeisanoff
owari = Cells(1, 1) + kai
For xx = 0 To 54
 For ii = 0 To owari Step kai
  Cells(i, 760 + xx) = Application.CountA(Range(Cells(4 + ii, 681 + xx), Cells(ii + kai + 3, 681 + xx)))
   If ii > 0 Then Cells(i - 1, 759) = ii
   i = i + 1
 Next ii
i = 4
Next xx
Call saikeisanon
End Sub
--------------------------------------------------------------------------------------------------------
Sub box_pear_total表示()    'ペア数字集計
patan = 0
UserForm5.Show 'ユーザーホームを開く
If patan = 1 Then
Call riset
Range( _
"BXK:BXK,BXU:BXU,BYD:BYD,BYL:BYL,BYS:BYS,BYY:BYY,BZD:BZD,BZH:BZH,BZK:BZK,BZM:BZM" _
).Select 'シングル表示
Range("Bxk1").Activate
Selection.EntireColumn.Hidden = True
End If
If patan = 2 Then
Call riset
Range("BXL:BXT,BXV:BYC,BYE:BYK,BYM:BYR,BYT:BYX,BYZ:BZC,BZE:BZG,BZI:BZJ,BZL:BZL" _
).Select 'ダブル表示
Range("BZL1").Activate
Selection.EntireColumn.Hidden = True
End If
Range("Bxk1").Activate
If patan = 3 Then
Call riset
End If
End Sub
--------------------------------------------------------------------------------------------------------
Sub box_pear_total表示_kai()    'ペア数字集計
patan = 0
UserForm5.Show 'ユーザーホームを開く
If patan = 1 Then
Call riset
Range( _
"acf:acf,acp:acp,acy:acy,adg:adg,adn:adn,adt:adt,ady:ady,aec:aec,aef:aef,aeh:aeh" _
).Select 'シングル表示
Range("Bxk1").Activate
Selection.EntireColumn.Hidden = True
End If
If patan = 2 Then
Call riset
Range("ACG:ACO,ACQ:ACX,ACZ:ADF,ADH:ADM,ADO:ADS,ADU:ADX,ADZ:AEB,AED:AEE,AEG:AEG" _
).Select 'ダブル表示
Range("AEG1").Activate
Selection.EntireColumn.Hidden = True
End If
Range("acg1").Activate
If patan = 3 Then
Call riset
End If
End Sub
--------------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
If patan = 0 Then MsgBox ("選択して下さい"): Exit Sub
Unload UserForm5 'ユーザーホームを閉じる
End Sub
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then patan = 1
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then patan = 2
End Sub
Private Sub OptionButton3_Click()
If OptionButton3.Value = True Then patan = 3
End Sub
-------------------------------------------------------------------------------------------------------
Sub riset()
Columns("BXJ:BZN").Select
Selection.EntireColumn.Hidden = False
End Sub
--------------------------------------------------------------------------------------------------------
Sub tripear_suuji()   'エタニティ数字
Dim j, i, k, d As Integer
j = 0
i = 4
k = 0
Sheets("23桁").Select
Range("B4:B6000").Select
Selection.Copy
  Range("AS4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 Call saikeisanoff
patann = 0
   Sheets("23桁").Select
UserForm1.Show 'ユーザーホームを開く
  Range("at4:je6000").Select
  Selection.ClearContents
Do Until Cells(i, 2) = ""
 For j = 1 To 4 '出目の入力348
  If Cells(i, j + 2).Value = "" Then Exit For
  d = Cells(i, j + 2).Value
 If d >= 0 And d <= 9 Then
  k = 0
ElseIf 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 >= 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
ElseIf d >= 111 And d <= 119 Then
  k = -56
ElseIf d >= 122 And d <= 129 Then
  k = -58
ElseIf d >= 133 And d <= 139 Then
  k = -61
ElseIf d >= 144 And d <= 149 Then
  k = -65
ElseIf d >= 155 And d <= 159 Then
  k = -70
ElseIf d >= 166 And d <= 169 Then
 k = -76
ElseIf d >= 177 And d <= 179 Then
  k = -83
ElseIf d >= 188 And d <= 189 Then
  k = -91
ElseIf d = 199 Then
  k = -100
ElseIf d >= 222 And d <= 229 Then
  k = -122
ElseIf d >= 233 And d <= 239 Then
  k = -125
ElseIf d >= 244 And d <= 249 Then
  k = -129
ElseIf d >= 255 And d <= 259 Then
  k = -134
ElseIf d >= 266 And d <= 269 Then
  k = -140
ElseIf d >= 277 And d <= 279 Then
  k = -147
ElseIf d >= 288 And d <= 289 Then
  k = -155
ElseIf d = 299 Then
  k = -164
ElseIf d >= 333 And d <= 339 Then
  k = -197
ElseIf d >= 344 And d <= 349 Then
  k = -201
ElseIf d >= 355 And d <= 359 Then
  k = -206
ElseIf d >= 366 And d <= 369 Then
  k = -212
ElseIf d >= 377 And d <= 379 Then
  k = -219
ElseIf d >= 388 And d <= 389 Then
  k = -227
ElseIf d = 399 Then
  k = -236
ElseIf d >= 444 And d <= 449 Then
  k = -280
ElseIf d >= 455 And d <= 459 Then
  k = -285
ElseIf d >= 466 And d <= 469 Then
  k = -291
ElseIf d >= 477 And d <= 479 Then
  k = -298
ElseIf d >= 488 And d <= 489 Then
  k = -306
ElseIf d = 499 Then
  k = -315
ElseIf d >= 555 And d <= 559 Then
  k = -370
ElseIf d >= 566 And d <= 569 Then
  k = -376
ElseIf d >= 577 And d <= 579 Then
  k = -383
ElseIf d >= 588 And d <= 589 Then
  k = -391
ElseIf d = 599 Then
  k = -400
ElseIf d >= 666 And d <= 669 Then
  k = -466
ElseIf d >= 677 And d <= 679 Then
  k = -473
ElseIf d >= 688 And d <= 689 Then
  k = -481
ElseIf d = 699 Then
  k = -490
ElseIf d >= 777 And d <= 779 Then
  k = -567
ElseIf d >= 788 And d <= 789 Then
  k = -575
ElseIf d = 799 Then
  k = -584
ElseIf d >= 888 And d <= 889 Then
  k = -672
ElseIf d = 899 Then
  k = -681
ElseIf d = 999 Then
 k = -780
End If
If patann = 1 Then
  Cells(i, d + 46 + k) = Cells(i, 15)
ElseIf patann = 2 Then
  Cells(i, d + 46 + k) = Cells(i, j + 2)
ElseIf patann = 3 Then
  Cells(i, d + 46 + k) = Cells(i, 1)
End If
Next j
  i = i + 1
  If i = 6001 Then Exit Do
Loop
 Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub kankaku_cunters() '古いタイプ
retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
If Cells(gyou, retu) = "" Then End
For i = 1 To 777
 If Cells(gyou + i, retu) = "" Then
   j = j + 1
 Else
  Exit For
 End If
Next i
If retu > 66 And retu < 77 Then
  Cells(gyou + i - 1, retu) = j
End If
actsheet = ActiveSheet.Name
 If actsheet <> "パターン表" Then '元データをコピーする。
   MsgBox "間隔は " & (j)
 End If
 If i = 999 Then End
End Sub
--------------------------------------------------------------------------------------------------------
Sub kankaku_cunters2() '以前の間隔チェック
retu = ActiveCell.Column
gyou = ActiveCell.Row
  j = 0
  i = 0
  If Cells(gyou, retu) = "" Then End
For i = 1 To 777
 If Cells(gyou - i, retu) = "" Then
   j = j + 1
 Else
  Exit For
 End If
Next i
If retu > 66 And retu < 77 Then
   If Cells(gyou - 1, retu) <> "" Then End
   Cells(gyou - 1, retu) = j
End If
actsheet = ActiveSheet.Name
If actsheet <> "パターン表" Then '元データをコピーする。
  MsgBox "間隔は " & (j)
  Cells(gyou, retu + 7) = j
  Cells(gyou, retu + 7).Select
End If
 Cells(gyou - 1, 103) = ""
 Cells(gyou, 103) = "*"
 If i = 999 Then End
End Sub
--------------------------------------------------------------------------------------------------------
Sub kankaku_cunters22() '新しい間隔チェック2015.03.28
 retu = ActiveCell.Column
 gyou = ActiveCell.Row
  j = 0
  i = 0
For jj = 1 To 9 Step 2 '引っ張り0にする
 Cells(gyou, 180 + jj) = 0
Next jj
For ii = 1 To 10
  For i = 1 To 100
    If Cells(gyou - i, 66 + ii) = "" Then
      j = j + 1
   Else
     Exit For
   End If
  If Cells(gyou, 66 + ii) <> "" Then Cells(gyou - 1, 66 + ii) = j
 Next i
  j = 0
Next ii
End Sub
--------------------------------------------------------------------------------------------------------
Sub gokei_color()  '合計変化の色ずけ
Dim totalbar As Range
ActiveWorkbook.Worksheets("パターン表").Select
gyou = ActiveCell.Row
If gyou <= 2 Then End
i = 1
Do Until Cells(i + gyou, 80) = ""
 Set totalbar = Application.Cells(gyou, 80)
  saki = Cells(i + gyou - 1, 80)
 If saki = Cells(i + gyou, 80) Then
  Cells(i + gyou, 80).Select
  With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
 End With
ElseIf saki < Cells(i + gyou, 80) Then
 Cells(i + gyou, 80).Select
 With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 10 '.Color = 10
.TintAndShade = 0
.Weight = xlThin
 End With
ElseIf saki > Cells(i + gyou, 80) Then
     Cells(i + gyou, 80).Select
 With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
 End With
 Cells(i + gyou, 80).Select
End If
 i = i + 1
 If i = 6000 Then Exit Do
Loop
End Sub
--------------------------------------------------------------------------------------------------------
Sub total間隔() '合計間隔でアンダーバー引く
   Dim i, k, gyou, total As Integer
   Dim totalbar, dtotalbar As Range
Worksheets("パターン表").Select
 gyou = ActiveCell.Row
 If ActiveCell.Column <> 80 Then End
 total = Cells(gyou, 80)
Set dtotalbar = Application.Cells(gyou, 27)
Set totalbar = Application.Cells(gyou, 80)
   i = 1
 Do Until total = Cells(gyou - i, 80)
  i = i + 1
  k = i - 1
  If i = 3000 Then Exit Do
Loop
If total = 5 Then ’合計5の時  余り出ない合計4以下や33以上は計算しない。
  If k >= 180 And k < 356 Then frg = 1
  If k >= 356 Then frg = 2
End If
If total = 6 Then
 If k >= 120 Then frg = 1
 If k >= 238 Then frg = 2
End If
If total = 7 Then
 If k >= 84 Then frg = 1
 If k >= 168 Then frg = 2
End If
If total = 8 Then
 If k >= 62 Then frg = 1
 If k >= 122 Then frg = 2
End If
If total = 9 Then’合計9の時
 If k >= 45 Then frg = 1
 If k >= 91 Then frg = 2
End If
If total = 10 Then
 If k >= 35 Then frg = 1
 If k >= 71 Then frg = 2
End If
If total = 11 Then
 If k >= 28 Then frg = 1
 If k >= 57 Then frg = 2
End If
If total = 12 Then
 If k >= 24 And k < 48 Then frg = 1
 If k >= 48 Then frg = 2
End If
If total = 13 Then
 If k >= 20 Then frg = 1
 If k >= 41 Then frg = 2
End If
If total = 14 Then
 If k >= 18 Then frg = 1
 If k >= 37 Then frg = 2
End If
If total = 15 Then’合計15の時
 If k >= 17 Then frg = 1
 If k >= 34 Then frg = 2
End If
If total = 16 Then
 If k >= 16 Then frg = 1
 If k >= 32 Then frg = 2
End If
If total = 17 Then
 If k >= 15 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 18 Then ’合計18の時
 If k >= 15 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 19 Then
 If k >= 15 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 20 Then
 If k >= 16 Then frg = 1
 If k >= 32 Then frg = 2
End If
If total = 21 Then
 If k >= 17 Then frg = 1
 If k >= 34 Then frg = 2
End If
If total = 22 Then
 If k >= 18 Then frg = 1
 If k >= 37 Then frg = 2
End If
If total = 23 Then
 If k >= 21 Then frg = 1
 If k >= 41 Then frg = 2
End If
If total = 24 Then
 If k >= 24 Then frg = 1
 If k >= 48 Then frg = 2
End If
If total = 25 Then
 If k >= 28 Then frg = 1
 If k >= 57 Then frg = 2
End If
If total = 26 Then
 If k >= 35 Then frg = 1
 If k >= 71 Then frg = 2
End If
If total = 27 Then
 If k >= 45 Then frg = 1
 If k >= 91 Then frg = 2
End If
If total = 28 Then
 If k >= 62 Then frg = 1
 If k >= 122 Then frg = 2
End If
If total = 29 Then
 If k >= 84 Then frg = 1
 If k >= 168 Then frg = 2
End If
If total = 30 Then
 If k >= 120 Then frg = 1
 If k >= 238 Then frg = 2
End If
If total = 31 Then
 If k >= 180 Then frg = 1
 If k >= 356 Then frg = 2
End If
If total = 32 Then’合計32
 If k >= 286 Then frg = 1
 If k >= 572 Then frg = 2
End If
If frg = 1 Then
 totalbar.Font.Underline = xlUnderlineStyleSingle
 dtotalbar.Font.Underline = xlUnderlineStyleSingle
ElseIf frg = 2 Then
 totalbar.Font.Underline = xlUnderlineStyleDouble
 dtotalbar.Font.Underline = xlUnderlineStyleDouble
Else
 totalbar.Font.Underline = xlUnderlineStyleNone
 dtotalbar.Font.Underline = xlUnderlineStyleNone
End If
' Cells(gyou + i, 80).Select
'  total間隔

End Sub
--------------------------------------------------------------------------------------------------------
Sub hotno_copy()
gocel = Cells(1, 2) + 10
Sheets("パターン表").Select
Range("R2:U5000").Select
Selection.Copy
Sheets("欠け算並び").Select
Range("eh10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(gocel, 138).Select
End Sub
--------------------------------------------------------------------------------------------------------
Sub kakezan_total()   '数字集計
Dim xx, ii, i, kai, owari As Integer
 Sheets("欠け算並び").Select
 i = 6
 Range("jz6:ls6334").Select
 Selection.ClearContents
Call saikeisanoff
 kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
 Cells(5, 286) = kai
 Application.ScreenUpdating = False '画面変更をしない。
 owari = Cells(1, 2) + kai
For xx = 0 To 45
 For ii = 0 To owari Step kai
Cells(i, 287 + xx) = Application.CountA(Range(Cells(8 + ii, 27 + xx), Cells(ii + kai - 1, 27 + xx)))
 If ii > 0 Then Cells(i - 1, 286) = ii
 i = i + 1
Next ii
i = 6
Next xx
Call saikeisanon
Application.ScreenUpdating = True '画面変更
End Sub