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

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

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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー