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

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

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


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



Public patann As Integer
 Public patan As Integer
 Dim stcolo As Range
 Dim goguucara As Range
 Dim tokiguu As Integer
 Dim kiguu(4) As String
 Dim hit(5000, 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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー



当選番号から出目パターン、合計、大小、奇遇、ボックス回数、シングルダブル、等を表示させる。
Sub patapata_4() '当選数字パターン貼付け(引張表作成)
 Dim i, j, k, dbl, kaigou As Integer
 Dim daida, Db As String
start = MsgBox("開始しますか?", vbYesNo)’マクロボタン押下でメッセージ出す
 If start = vbNo Then End ’中止する時
Worksheets("パターン表").Select
kaigou = Cells(1, 26)  ’回号を変数に入れる。
Range(Cells(2, 17), Cells(kaigou + 1, 17)).Select
Selection.Copy
Range("BN2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Bo2:Bz4500", "ca2:ca4500").Select ' 出目パターン表示部をクリアする
Selection.ClearContents
Application.ScreenUpdating = False '画面変更をしない。
Call saikeisanoff
 Range("BW2").Activate
 Erase hit ’配列変数の内容をクリア(取りあえずw)
i = 2
Do Until Cells(i, 18) = "" ’ Cells(i, 18)のデータが無くなる迄下の処理をする。
dai = 0
For j = 1 To 4 ' 4つの出目の配列変数への入力
   hit(i - 1, j) = Cells(i, j + 17)
      If hit(i - 1, j) >= 5 Then dai = dai + 1 ’出目の大小、5以上の集計
      kiguu(j) = Cells(i, j + 21)
       If kiguu(j) = "偶" Then kiguu(j) = "▲" Else kiguu(j) = "△"
  If j = 4 Then ’4つの出目の奇遇偶数を集計する
 Cells(i, 81) = kiguu(1) + kiguu(2) + kiguu(3) + kiguu(4)
  End If
Next j
    Select Case dai '大小の表示
      Case 0: daida = "■■■■" ’4以下4つの時
      Case 1: daida = "■■■□" ’4以下3つの時
      Case 2: daida = "■■□□" ’4以下2つの時
      Case 3: daida = "■□□□" ’4以下1つの時
      Case 4: daida = "□□□□" ’4以下0の時
   End Select
Cells(i, 79) = daida
i = i + 1 ’ Cells(i, 18) のiの部分が1づつ増えて行く(下の行に向かっていく)
k = i
If i = 4501 Then Exit Do
Loop
witi = 67 ’表示する列のスタート位置----出目0の時は67列目
For i = 1 To k - 2
For j = 1 To 4 '出目パターン作成(4出目分)
If Cells(i + 1, witi + hit(i, j)) = "" Then
   Cells(i + 1, witi + hit(i, j)) = "●"
ElseIf Cells(i + 1, witi + hit(i, j)) = "●" Then
   Cells(i + 1, witi + hit(i, j)) = "◎" ’ダブルの時◎にする。
    dbl = dbl + 1
      If dbl = 1 Then Db = "2" Else Db = " d2"
    Cells(i + 1, witi + 11) = Db  
ElseIf Cells(i + 1, witi + hit(i, j)) = "◎" Then
   Cells(i + 1, witi + hit(i, j)) = "☆" ’トリプルの時☆にする。
   Cells(i + 1, witi + 11) = 3
ElseIf Cells(i + 1, witi + hit(i, j)) = "☆" Then
   Cells(i + 1, witi + hit(i, j)) = "★" ’フォースの時
   Cells(i + 1, witi + 11) = 4
End If
Next j
dbl = 0  
Next i
Call box 'ボックス回数カウント等  Sub box()を呼び出して実行させる。 
Application.ScreenUpdating = True
Call 当選番号表示’サブルーチン(サブプログラム)呼び出す
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
'当選番号を小さい順に並び替えて、該当番号の累計出現回数を計算
 ストレート番号が何回出たかを色別の縦線で表示


Sub box() 
Dim moji(5000) As String
Dim i, j, x, rencyan, caler As Integer
Range("ce2:ce5000").Select
Selection.NumberFormatLocal = "@"
Selection.ClearContents
i = 2
Do Until Cells(i, 18) = ""
For k = 1 To 3
  For j = 1 To 3
      If hit(i - 1, j) > hit(i - 1, j + 1) Then ’出目を小さい順に並びかえする。
      daisyou = hit(i - 1, j)
    hit(i - 1, j) = hit(i - 1, j + 1)
    hit(i - 1, j + 1) = daisyou
      End If    
  Next j
Next k
For j = 1 To 4 ’当選番号をボックス番号にする(小さい順に並べて)
    moji(i) = Trim(moji(i)) + Trim(Str(hit(i - 1, j)))
If j = 4 Then 'ボックス累計回数計算 
Cells(i, 83) = moji(i) ’ボックス(bkとする)番号表示する
Cells(i, 84) = Application.CountIf(Range(Cells(2, 83), Cells(i, 83)), Cells(i, 83))  ’bk回数   
End If
Next j
     caler = Application.CountIf(Range(Cells(2, 66), Cells(i, 66)), Cells(i, 66)) 
   Set stcolo = Application.Cells(i, 66)
  stcolo.Borders(xlEdgeLeft).ColorIndex = 1
If caler = 2 Then 'ストレート2回目当選番号の左の線を黄色にする       
  stcolo.Borders(xlEdgeLeft).ColorIndex = 4
ElseIf caler = 3 Then 'ストレート3回目当選番号の左の線を赤色にする    
  stcolo.Borders(xlEdgeLeft).ColorIndex = 3       
ElseIf caler >= 4 Then 'ストレート4回目以上両脇赤色にする     
  stcolo.Borders(xlEdgeLeft).ColorIndex = 3
  stcolo.Borders(xlEdgeRight).ColorIndex = 3      
End If
For x = 1 To 10 '連荘数      
  If Cells(i, 66 + x) <> "" And Cells(i + 1, 66 + x) <> "" Then
    rencyan = rencyan + 1       
  End If
Next x
If rencyan > 0 Then Cells(i + 1, 77) = rencyan     
rencyan = 0
  If i = 5000 Then Exit Do
i = i + 1
Loop
Range(Cells(i, 80), Cells(i, 80)).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー  Sub 当選番号表示() 'たとえば6731を6 7 3 1にしたのをコピー 
Worksheets("パターン表").Range("GM2:GM5000").Copy
lasty = Cells(1, 26) + 1
Range("bn2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(lasty, 66).Select
End Sub  
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box間隔2k()'上手く動かないのでbox間隔マクロを2回計算している。
box間隔
box間隔
End Sub
--------------------------------------
 Sub box間隔() 'box間隔計算
Dim i, k, gyou As Integer
Dim boxspan As String
Worksheets("パターン表").Select
gyou = ActiveCell.Row
If Cells(gyou, 84) = 0 Then End
  boxspan = Cells(gyou, 83)
Application.ScreenUpdating = False '画面変更をしない。
If Cells(gyou, 84) = 1 Then '始めてなら
Cells(gyou, 115) = gyou - 1
If gyou > 2000 Then '2000回以降に出たら二重線を引く
Cells(gyou, 115).Select
Selection.Font.Underline = xlUnderlineStyleDouble
End If
Exit Sub
End If
   i = 1
Do Until boxspan = Cells(gyou - i, 83)
i = i + 1
If i = 3333 Then Exit Do
Loop
Cells(gyou, 115) = i '間隔記入する
Cells(gyou - i, 78).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 78).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(gyou - i, 83).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 83).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 84).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 84).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 103).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 103).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 115).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 115).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
  Range(Cells(gyou - i, 116), Cells(gyou - i, 121)).Select
Selection.Copy '欠け算コピー
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 116), Cells(gyou, 127)).Select
  Selection.Font.Underline = xlUnderlineStyleNone
Range("DL11:EB11").Select '10回出目からINTまで計算式コピーする。
Selection.Copy
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 116), Cells(gyou, 132)).Select
Selection.Copy
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False            
Range("da11:dj11").Select '計算式コピーする。
Selection.Copy
Cells(gyou, 105).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 105), Cells(gyou, 114)).Select
Selection.Copy
Cells(gyou, 105).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False       
Range("cv11:cy11").Select '全中後連番まで計算式コピーする。
Selection.Copy
Cells(gyou, 100).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 100), Cells(gyou, 102)).Select
Selection.Copy
Cells(gyou, 100).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False    
Application.ScreenUpdating = True '画面変更。
Cells(gyou, 83).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー


'デジタルナンバーズ考案の強弱順位を手入力後パターン表示
Sub kyoujyaku()
Erase hit
Worksheets("パターン表").Select
start = MsgBox("強弱順位開始しますか?", vbYesNo)
If start = vbNo Then End
 Range("Bd2:Bm5000").Select
Selection.ClearContents
Range("ar2:Ba5000").Select
      With Selection.Font
       .ColorIndex = xlAutomatic
       .TintAndShade = 0
     End With
Call saikeisanoff
Application.ScreenUpdating = False '画面変更をしない。
i = 8
witi = 55
Do Until Cells(i, 18) = ""
For j = 1 To 4
hit(i - 7, j) = Cells(i, j + 17)
For m = 1 To 10
If hit(i - 7, j) = Cells(i - 1, m + 43) Then
    If Cells(i, witi + m) = "" Then
       Cells(i, witi + m) = "●"
    ElseIf Cells(i, witi + m) = "●" Then 
       Cells(i, witi + m) = "◎"
    ElseIf Cells(i, witi + m) = "◎" Then
       Cells(i, witi + m) = "☆"
    ElseIf Cells(i, witi + m) = "☆" Then
       Cells(i, witi + m) = "★"
    End If
End If
Next m
Next j   
For k = 1 To 10
If Cells(i, 55 + k) <> "" Then
     Cells(i, 43 + k).Select   
     With Selection.Font
       .Color = -16776961
       .TintAndShade = 0
     End With              
End If    
Next k     
If i = 5000 Then Exit Do
i = i + 1 
Loop
Application.ScreenUpdating = True '画面変更。
Range(Cells(i, witi), Cells(i, witi)).Select
Call saikeisanon
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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

 ' =COUNTIF($R$4492:$U$4501,AI4501)を=COUNTIF($R$4502:$U$4511,AI4502)に変換


Sub 間隔計算式__置換()   '計算式置換コピーテストWhat:="4302", Replacement:="4312"
Dim gyou, retu As Integer
Worksheets("パターン表").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <> 36 And retu <> 88 Then End
a_gyou = gyou - 10
b_gyou = gyou - 1
c_gyou = gyou + 9
 Cells(gyou, retu).Select
  ActiveCell.Replace What:=a_gyou, Replacement:=gyou, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
  ActiveCell.Replace What:=b_gyou, Replacement:=c_gyou, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

 Sub deme4間隔() 'deme間隔でアンダーバー引く(青色部)
Dim i, k, gyou, retu, deme, ndeme, yiti  As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Range
Worksheets("パターン表").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If ActiveCell.Column <= 137 And ActiveCell.Column >= 142 Then End
   deme = Cells(gyou, retu) '出目
yiti = deme - Cells(gyou, 85) '出目の位置
 Set demebar = Application.Cells(gyou, retu)
Set ndemebar = Application.Cells(gyou + yiti, retu + 70) '桁別に88行から出目対応して上下に
Set tdemebar = Application.Cells(gyou, 116 + deme) '10出目毎に
i = 1 
Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1 
If i = 2000 Then Exit Do
Loop
If k >= 10 And k <= 29 Then
   demebar.Font.Underline = xlUnderlineStyleSingle
   ndemebar.Font.Underline = xlUnderlineStyleSingle
   tdemebar.Font.Underline = xlUnderlineStyleSingle
ElseIf k >= 30 Then
   demebar.Font.Underline = xlUnderlineStyleDouble
   ndemebar.Font.Underline = xlUnderlineStyleDouble
   tdemebar.Font.Underline = xlUnderlineStyleDouble
Else
   demebar.Font.Underline = xlUnderlineStyleNone
   ndemebar.Font.Underline = xlUnderlineStyleNone
End If
  Cells(gyou + 1, retu).Select
'deme4間隔
'  return0

     '自動で脇の桁に移動
   If Cells(gyou + 1, retu) = "" Then
       Cells(gyou, retu + 1).Select
      End
   End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

'奇偶判別 マクロ関数    arg_BNum1が v4344にーー arg_BNum4 がY4344に対応
(マクロで関数を(奇偶並びで16パターン判別用)作成)


Function set_NUFkiguu(arg_BNum1 As String, _
                               arg_BNum2 As String, _
                               arg_BNum3 As String, _
                               arg_BNum4 As String) As Integer                              
Dim kigu As Integer     
   If arg_BNum1 = "奇" And arg_BNum2 = "奇" Then
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 1
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 3
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 4
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 11
   End If  
  If arg_BNum1 = "偶" And arg_BNum2 = "偶" Then
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 2
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 7
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 8
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 14     
   End If  
If arg_BNum1 = "奇" And arg_BNum2 = "偶" Then
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 5
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 12
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 13
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 10
   End If  
If arg_BNum1 = "偶" And arg_BNum2 = "奇" Then
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 9
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 15
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 16
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 6
   End If
 set_NUFkiguu = kigu
End Function
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

'大小判別 マクロ関数
Function set_NUFdaisyo(arg_BNum As String) As Integer
 Dim daisyo As Integer
daisyo = 0
     If arg_BNum = "□□□□" Then daisyo = 1
     If arg_BNum = "■■■■" Then daisyo = 2
     If arg_BNum = "□□□■" Then daisyo = 3
     If arg_BNum = "□□■□" Then daisyo = 4
     If arg_BNum = "□■□□" Then daisyo = 5
     If arg_BNum = "■□□□" Then daisyo = 6
     If arg_BNum = "■■■□" Then daisyo = 7
     If arg_BNum = "■■□■" Then daisyo = 8
     If arg_BNum = "■□■■" Then daisyo = 9
     If arg_BNum = "□■■■" Then daisyo = 10
     If arg_BNum = "□□■■" Then daisyo = 11
     If arg_BNum = "□■□■" Then daisyo = 12
     If arg_BNum = "□■■□" Then daisyo = 13
     If arg_BNum = "■■□□" Then daisyo = 14
     If arg_BNum = "■□■□" Then daisyo = 15
     If arg_BNum = "■□□■" Then daisyo = 16
set_NUFdaisyo = daisyo
End Function
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー