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

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

4.No.3 分析

Sub Copi_propaty()
Dim Maxx, gokeimax, start As Integer
start = MsgBox("「データ集計」を「プロパテイ」にコピーしますか?", vbYesNo)
Call saikeisanoff '再計算を止めて計算を速くする
If start = vbNo Then End
Sheets("プロパテイ").Select
Range("C15:AVF96").ClearContents
Sheets("原本").Select
If Cells(15, 205) <> "" Then MsgBox ("整列してからです"): End
Maxx = Cells(1, 196) + 3
gokeimax = Cells(1, 198)
Range(Cells(2300, 204), Cells(2300 + gokeimax, 223)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(16, Maxx - gokeimax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'-----------------------------------------
Sheets("原本").Select '奇数偶数
kigumax = Cells(1, 239)
Range(Cells(2300, 241), Cells(2300 + kigumax, 248)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
'Range("C43").Select
Cells(43, Maxx - kigumax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'-----------------------------------
Sheets("原本").Select '大小
daisyomax = Cells(1, 259)
Range(Cells(2300, 261), Cells(2300 + daisyomax, 268)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(53, Maxx - daisyomax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'------------------------------
Sheets("原本").Select
minipmax = Cells(1, 278)
Range(Cells(2300, 280), Cells(2300 + minipmax, 298)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(64, Maxx - minipmax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'----------------------------
Sheets("原本").Select
minismax = Cells(1, 308)
Range(Cells(2300, 310), Cells(2300 + minismax, 319)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("c87").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Cells(1, 1) = Sheets("原本").Cells(1, 197)
Sheets("原本").Select
Range("GV5:HO5").Select
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE16").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("IG5:IN5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE43").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("JA5:JH5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE53").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("JT5:KL5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("KX5:LG5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE87").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Call saikeisanon '再計算
Range("a3").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub TKGM_seiretu()   '番号,回号、間隔を下並び出力。
Dim gokei_max, kigu_max, daisyo_max, mini_pmax, mini_smax As Integer
Dim i, ii, j, jj, k, start As Integer
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("原本").Select
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 198)
For i = 0 To 27
        motosuu = Cells(7, i + 200)
      If Cells(2300, i + 200) = "" Then End
If gokei_max > motosuu Then
  Range(Cells(10, i + 200), Cells(gokei_max - motosuu + 9, i + 200)).Select
  Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
kigu_max = Cells(1, 239)
For ii = 1 To 8
motosuu = Cells(7, ii + 240)
If kigu_max > motosuu Then
Range(Cells(10, ii + 240), Cells(kigu_max - motosuu + 9, ii + 240)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next ii
daisyo_max = Cells(1, 259)
For j = 1 To 8
motosuu = Cells(7, j + 260)
If daisyo_max > motosuu Then
Range(Cells(10, j + 260), Cells(daisyo_max - motosuu + 9, j + 260)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next j
mini_pmax = Cells(1, 278)
For jj = 0 To 18
motosuu = Cells(7, jj + 280)
If mini_pmax > motosuu Then
Range(Cells(10, jj + 280), Cells(mini_pmax - motosuu + 9, jj + 280)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next jj
mini_smax = Cells(1, 308)
For k = 0 To 9
motosuu = Cells(7, k + 310)
If mini_smax > motosuu Then
Range(Cells(10, k + 310), Cells(mini_smax - motosuu + 9, k + 310)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next k
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub HotNo_Seiretu()
Sheets("すとれ-と").Select
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Range("ej4:fm1000").Clear
Range("DB2:EE2").Select
Selection.Copy
Range("EJ2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("DB4:EE462").Select
Application.CutCopyMode = False
Selection.Copy
Range("EJ4").Select
ActiveSheet.Paste
gokei_max = Cells(2, 139)
For j = 1 To 30
motosuu = Cells(2, j + 139)
Range(Cells(4, j + 139), Cells(4 + motosuu, j + 139)).Select '番号,
Selection.Cut
Cells(4 + gokei_max - motosuu, j + 139).Select
ActiveSheet.Paste
Next j
Range("EJ4:FM456").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub next_spac() '次spaceを表示する
Sheets("原本").Select
Range("lp4:ly6000").ClearContents '出力表示部のクリア
Call saikeisanoff '再計算を止めて計算を速くする
i = 3
Do Until Cells(i, 106) = ""
retu_1 = Cells(i, 106).Value + 328
nextotal = Cells(i + 1, 106).Value
caunter = Application.Count(Range(Cells(5, retu_1), Cells(500, retu_1)))
Cells(3, retu_1) = caunter
Cells(caunter + 5, retu_1) = nextotal
i = i + 1
If i = 4001 Then Exit Do
Loop
Call saikeisanon '再計算をオンにする
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub nextspac_seiretu3()  
Dim gokei_max As Integer
Dim i, ii, j, jj, k, start As Integer
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 338)
For i = 0 To 9
  motosuu = Cells(3, i + 328)
  Range(Cells(5, i + 328), Cells(5 + motosuu, i + 328)).Select '番号,
  Selection.Cut
   Cells(5 + gokei_max - motosuu, i + 328).Select
  ActiveSheet.Paste
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 当選番号表示()
Sheets("原本").Select
lasty = Cells(1, 12) + 3
Range(Cells(3, 157), Cells(lasty, 157)).Select
Selection.Copy
Range("BX3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(lasty, 15).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力赤丸()
Dim maruiti As Range
Sheets("すとれ-と").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
If Cells(gyou, retu) <> "●" Then End
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.Color = -16776961
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
Cells(gyou + j, retu).Select
End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hotno_sin()
Dim maruiti As Range
Sheets("原本").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 53
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力へ()
  actsheet = ActiveSheet.Name
If actsheet = "原本" Then
retu = 12: w = 4: h = 0
ElseIf actsheet = "すとれ-と" Then
retu = 47: w = 3: h = 1
End If
jp = Cells(1, retu) + 3 + h
Cells(jp, w).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 原本へ()
Sheets("原本").Select
End Sub


Sub 二桁へ()
Sheets("二桁").Select
Range("c5").Select
End Sub


Sub laster()
jp = Cells(10, 1) + 7
Cells(jp + 4, 3).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Hotcopy()
Sheets("原本").Select
Range("E3:G5000").Select
Selection.Copy
Range("FJ3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
jp = Cells(1, 24) + 3
Cells(jp, 166).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub l_lin_edrow() '右下に斜めに線を引く
'hippari If retu>75 Then retu = 67: Cells(gyou + 1, retu).Select: End
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 > 85 Then retu = 76
Cells(gyou + 1, retu + 1).Select                
l_lin_edrow                
End If
Cells(gyou + 1, retu + 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub r_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 < 78 Then retu = 86: Cells(gyou + 1, retu).Select: End
Cells(gyou + 1, retu - 1).Select
r_line_drow
End If
Cells(gyou + 1, retu - 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub deme_st3間隔() 'deme間隔でアンダーバー引く
Dim i, k, gyou, retu, deme, ndeme, yiti  As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Object
Worksheets("原本").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <= 165 Or retu >= 169 Then End
deme = Cells(gyou, retu)
If deme = "" Then End
Set demebar = Application.Cells(gyou, retu)
Set ndemebar = Application.Cells(gyou, retu + 8)
i = 1
Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1
If i = 2000 Then Exit Do
Loop
If k >= 11 And k <= 29 Then
demebar.Font.Underline = xlUnderlineStyleSingle
ndemebar.Font.Underline = xlUnderlineStyleSingle
ElseIf k >= 30 Then
demebar.Font.Underline = xlUnderlineStyleDouble
ndemebar.Font.Underline = xlUnderlineStyleDouble
Else
demebar.Font.Underline = xlUnderlineStyleNone
ndemebar.Font.Underline = xlUnderlineStyleNone
End If
If k = 0 Then
Cells(gyou, retu + 8) = 0
Else
Cells(gyou, retu + 8) = k
End If
Cells(gyou + 1, retu).Select
'自動で脇の桁に移動
If Cells(gyou + 1, retu) = "" Then
Cells(gyou - 3, retu + 1).Select
End
End If
deme_st3間隔
'return0
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

  Sub 間隔計算式__置換()   '計算式置換  上の式をコピーした後マクロ実行する。
Dim gyou, retu As Integer
 Worksheets("原本").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <> 25  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
   
   Selection.Copy
    Range(Cells(gyou, retu), Cells(gyou + 9, retu)).Select '10行分貼り付け
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hanntei_2()
Dim hani As Integer
Sheets("ミニ出現数 ").Select
saikeisanoff
For i = 1 To 101
h = 1
 Do Until Cells(2 + i, h + 3) = ""
  If h = 1 Then
      hani = Cells(2 + i, h + 3)
  Else
      hani = Cells(2 + i, h + 3) - Cells(2 + i, h + 2)
  End If
  If hani <= 50 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 10 '緑4
  ElseIf hani > 50 And hani <= 100 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 1 '青53=茶黒1
  ElseIf hani >= 101 And hani <= 300 Then
      Cells(2 + i, h + 3).Select
       Selection.Font.ColorIndex = 3 '赤
  ElseIf hani > 300 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 3 '赤
   Selection.Font.Bold = True
   End If
  h = h + 1
  If h = 60 Then Exit Do
 Loop
  h = 0
Next i
  saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub HOTNO_3iroiti()
gyou = ActiveCell.Row
retu = ActiveCell.Column             
Cells(500, retu + 90).Select
i = 0
Do Until Cells(500 + i, retu + 90) <> ""     
  i = i - 1              
 If i < -500 Then Exit Do
Loop           
Cells(500 + i, retu + 90).Select      
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                      
Sub HotNo_3Kanakuiti()
Dim kankaku_d, kankakukijyunn As Integer              
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)               
Cells(85, retu + 91).Select
kankakukijyunn = Cells(19, retu + 91) + 20
If kankaku_d <= 3 Then
Cells(kankakukijyunn, retu + 91).Select
End
End If
i = 0
Do Until Cells(85 + i, retu + 91) = ""     
   i = i + 1        
   If i = 500 Then Exit Do
Loop
Cells(85 + i, retu + 91).Select
start = MsgBox(kankaku_d & " 間隔はok?", vbYesNo)
If start = vbYes Then
  Cells(85 + i, retu + 91) = kankaku_d
  Cells(kankakukijyunn + 1, retu + 91).Select
Else
  End
End If
End Sub               
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                      
Sub HotNo_3KanakuWriter()
Dim kankaku_d As Integer              
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)
Cells(85, retu + 91).Select
If kankaku_d <= 3 Then
h = 0
Do Until Cells(20 + h, retu + 91) = ""
h = h + 1
Cells(19 + h, retu + 91).Select
If h = 50 Then Exit Do
Loop
End
End If
i = 0
Do Until Cells(85 + i, retu + 91) = ""        
  i = i + 1         
 If i = 500 Then Exit Do
Loop
Cells(85 + i, retu + 91).Select
start = MsgBox(kankaku_d & " 間隔はok?", vbYesNo)
If start = vbYes Then
  Cells(85 + i, retu + 91) = kankaku_d
Else
  End
End If
Cells(Cells(5, retu + 91) + 34, retu + 91).Select             
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                                    
Sub HotNo_3KanakuWriter_moto()
Dim kankaku_d As Integer             
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)
Cells(85, retu + 91).Select
i = 0
Do Until Cells(85 + i, retu + 91) = ""  
  i = i + 1            
 If i = 500 Then Exit Do
Loop
If kankaku_d > 3 Then
    Cells(85 + i, retu + 91) = kankaku_d
Else
    Cells(20, retu + 91).Select: End
End If
Cells(85 + i, retu + 91).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー            

'土日を除いて日付を追加する。最後の日付の下で実行
Sub dayplus3()
Dim gyou As Integer             
Worksheets("原本").Select ’実行するシートを指定する。
gyou = ActiveCell.Row ’選択行を変数に入れる。
Cells(gyou - 1, 2).Copy Cells(gyou, 2)
Cells(gyou, 2) = Cells(gyou, 2) + 3 ’月曜日の日付を入れる。
’下の処理で火曜日~金曜日を入れる。
Selection.AutoFill Destination:=Range(Cells(gyou, 2), Cells(gyou + 4, 2)), Type:=xlFillDefault
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー    



3.No.3 分析

Sub kiguu3間隔() '奇数偶数の間隔でアンダーバー引く
Dim i, k, gyou, kiguu As Integer
Dim kiguubar, nkiguubar As Range 'オブジェクト変数を設定する。
Worksheets("原本").Select
  gyou = ActiveCell.Row
  If ActiveCell.Column <> 92 Then End
    kiguu = Cells(gyou, 92)
  Set kiguubar = Application.Cells(gyou, 92)'オブジェクト変数にセル範囲を設定する。
  Set nkiguubar = Application.Cells(gyou, 12)
   i = 1
Do Until kiguu = Cells(gyou - i, 92)
   i = i + 1
   k = i - 1
  If i = 4000 Then Exit Do
Loop
If k < 9 Then  ’間隔8以下は何も線無し
 kiguubar.Font.Underline = xlUnderlineStyleNone'オブジェクト変数のセルのプロパティを設定。
 nkiguubar.Font.Underline = xlUnderlineStyleNone
ElseIf k >= 9 And k < 19 Then ’間隔9以上18以下に下線
 kiguubar.Font.Underline = xlUnderlineStyleSingle
 nkiguubar.Font.Underline = xlUnderlineStyleSingle
Else’間隔19以上に二重線
 kiguubar.Font.Underline = xlUnderlineStyleDouble
 nkiguubar.Font.Underline = xlUnderlineStyleDouble
End If
 'kiguu3間隔  '同じ処理を繰り返す時(再帰処理をする)
End Sub
------------------------------  

 Sub deme3間隔() 'deme間隔でアンダーバー引く
 Dim i, k, gyou, retu, deme As Integer
 Dim demebar, demebar2 As Range
Worksheets("原本").Select
On Error GoTo errorcheck
gyou = ActiveCell.Row
retu = ActiveCell.Column
If ActiveCell.Column <= 4 And ActiveCell.Column >= 8 Then End
deme = Cells(gyou, retu)
Set demebar = Application.Cells(gyou, retu)
Set demebar2 = Application.Cells(gyou, retu + 169)
i = 1 
Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1   
If i = 2000 Then Exit Do
Loop
If k < 11 Then
demebar.Font.Underline = xlUnderlineStyleNone
demebar2.Font.Underline = xlUnderlineStyleNone
ElseIf k >= 11 And k <= 29 Then
demebar.Font.Underline = xlUnderlineStyleSingle
demebar2.Font.Underline = xlUnderlineStyleSingle
Else
demebar.Font.Underline = xlUnderlineStyleDouble
demebar2.Font.Underline = xlUnderlineStyleDouble
End If


Cells(gyou + 1, retu).Select   
If k = 0 Then
Cells(gyou, retu + 169) = 0
Else
Cells(gyou, retu + 169) = k
End If       


'deme3間隔
'自動で脇の桁に移動
If Cells(gyou + 1, retu) = "" Then
  Cells(gyou, retu + 1).Select
End
End If      
Exit Sub
errorcheck:
MsgBox "エラー番号" & Err & ":" & Error(Err): End  
End Sub
------------------------------ 
Sub total3間隔() '出目合計間隔でアンダーバー選択(各合計の確率により)
Dim i, k, gyou, total As Integer
Dim totalbar As Range
Worksheets("原本").Select
  gyou = ActiveCell.Row
If ActiveCell.Column <> 90 Then End
 total = Cells(gyou, 90)
 Set totalbar = Application.Cells(gyou, 90)
 i = 1
Do Until total = Cells(gyou - i, 90)
 i = i + 1
 k = i - 1
If i = 3000 Then Exit Do
Loop
 If total = 7 Then’合計7の時
    If k >= 29 And k < 58 Then frg = 1’フラグ1とする
   If k >= 58 Then frg = 2
End If
If total = 8 Then
 If k >= 24 And k < 48 Then frg = 1
 If k >= 48 Then frg = 2
End If
If total = 9 Then
 If k >= 20 And k < 40 Then frg = 1
 If k >= 40 Then frg = 2
End If
If total = 10 Then
 If k >= 17 And k < 34 Then frg = 1
 If k >= 34 Then frg = 2
End If
If total = 11 Then
 If k >= 13 And k < 32 Then frg = 1
 If k >= 32 Then frg = 2
End If
If total = 12 Then
 If k >= 15 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 13 Then
 If k >= 15 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 14 Then
 If k >= 15 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 15 Then
 If k >= 15 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 16 Then
 If k >= 16 And k < 32 Then frg = 1
 If k >= 32 Then frg = 2
End If
If total = 17 Then
 If k >= 17 And k < 34 Then frg = 1
 If k >= 34 Then frg = 2
End If
If total = 18 Then
 If k >= 20 And k < 40 Then frg = 1
 If k >= 40 Then frg = 2
End If
If total = 19 Then
 If k >= 24 And k < 48 Then frg = 1
 If k >= 48 Then frg = 2
End If
If total = 20 Then
 If k >= 29 And k < 58 Then frg = 1
 If k >= 58 Then frg = 2
End If
If frg = 1 Then
 totalbar.Font.Underline = xlUnderlineStyleSingle
 ElseIf frg = 2 Then
 totalbar.Font.Underline = xlUnderlineStyleDouble
Else
 totalbar.Font.Underline = xlUnderlineStyleNone
End If
 'total3間隔
End Sub
------------------------------ 
Sub total3mini間隔() 'ミニの間隔でアンダーバー引く
Dim i, k, gyou, total, frg As Integer
Dim totalbar As Range
Worksheets("原本").Select
  gyou = ActiveCell.Row
  If ActiveCell.Column <> 105 Then End
  total = Cells(gyou, 105)
   Set totalbar = Application.Cells(gyou, 105)
 i = 1
Do Until total = Cells(gyou - i, 105)
 i = i + 1
 k = i - 1
 If i = 3000 Then Exit Do
Loop
 frg = 0
If total = 0 Or total = 18 Then
 If k >= 50 And k < 100 Then frg = 1
 If k >= 100 Then frg = 2
End If
If total = 1 Or total = 17 Then
 If k >= 100 And k < 200 Then frg = 1
 If k >= 200 Then frg = 2
End If
If total = 2 Or total = 16 Then
 If k >= 34 And k < 68 Then frg = 1
 If k >= 68 Then frg = 2
End If
If total = 3 Or total = 15 Then
 If k >= 26 And k < 50 Then frg = 1
 If k >= 50 Then frg = 2
End If
If total = 4 Or total = 14 Then
 If k >= 21 And k < 40 Then frg = 1
 If k >= 40 Then frg = 2
End If
If total = 5 Or total = 13 Then
 If k >= 18 And k < 34 Then frg = 1
 If k >= 34 Then frg = 2
End If
If total = 6 Or total = 12 Then
 If k >= 16 And k < 30 Then frg = 1
 If k >= 30 Then frg = 2
End If
If total = 7 Or total = 11 Then
 If k >= 14 And k < 26 Then frg = 1
 If k >= 26 Then frg = 2
End If
If total = 8 Or total = 10 Then
 If k >= 13 And k < 24 Then frg = 1
 If k >= 24 Then frg = 2
End If
If total = 9 Then
 If k >= 11 And k < 20 Then frg = 1
 If k >= 20 Then frg = 2
End If
 If frg = 1 Then
 totalbar.Font.Underline = xlUnderlineStyleSingle
ElseIf frg = 2 Then
 totalbar.Font.Underline = xlUnderlineStyleDouble
Else
 totalbar.Font.Underline = xlUnderlineStyleNone
End If
'  total3mini間隔
  End Sub
------------------------------   
Sub Spase3mini間隔() 'ミニスペース間隔でアンダーバー引く
Dim i, k, gyou, space, frg As Integer
Dim spacebar As Range
  Worksheets("原本").Select
  gyou = ActiveCell.Row
  If ActiveCell.Column <> 106 Then End
  space = Cells(gyou, 106)
   Set spacebar = Application.Cells(gyou, 106)
   i = 1
Do Until space = Cells(gyou - i, 106)
 i = i + 1
 k = i - 1
 If i = 5000 Then Exit Do
Loop
 frg = 0
If space = 0 Or space = 5 Then
 If k >= 11 And k <= 21 Then frg = 1
 If k >= 22 Then frg = 2
End If
If space = 1 Then
 If k >= 6 And k <= 11 Then frg = 1
 If k >= 12 Then frg = 2
End If
If space = 2 Then
 If k >= 7 And k <= 13 Then frg = 1
 If k >= 14 Then frg = 2
End If
If space = 3 Then
 If k >= 8 And k <= 15 Then frg = 1
 If k >= 16 Then frg = 2
End If
If space = 4 Then
 If k >= 9 And k <= 17 Then frg = 1
 If k >= 18 Then frg = 2
End If
If space = 6 Then
 If k >= 13 And k <= 25 Then frg = 1
 If k >= 26 Then frg = 2
End If
If space = 7 Then
 If k >= 17 And k <= 33 Then frg = 1
 If k >= 34 Then frg = 2
End If
If space = 8 Then
 If k >= 26 And k <= 51 Then frg = 1
 If k >= 52 Then frg = 2
End If
If space = 9 Then
 If k >= 51 And k <= 101 Then frg = 1
 If k >= 102 Then frg = 2
End If
If frg = 1 Then
 spacebar.Font.Underline = xlUnderlineStyleSingle
ElseIf frg = 2 Then
 spacebar.Font.Underline = xlUnderlineStyleDouble
Else
 spacebar.Font.Underline = xlUnderlineStyleNone
End If
' Spase3mini間隔
End Sub
------------------------------ 
Sub stpear_suji()   'ペアストレート数字百十、百一、十一に別に回号、間隔、番号を出力。
Dim j, k, i, n, caunter, Maxx, setretu, span, writretu As Integer
   Sheets("原本").Select
   Call saikeisanoff '再計算を止めて計算を速くする
   caunter = 0
   Range("BXL4:EAE3904").Select '出力表示部のクリア
   Selection.ClearContents
i = 4
Do Until Cells(i, 1899) = "" And Cells(i, 1900) = ""
 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)   '回号データを記入する。
If caunter = 0 Then '回号データの間隔を300行から記入する
 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   '合計カウンタを計算表示する
Next n
 i = i + 1
 If i = 4001 Then Exit Do
Loop
Call saikeisanon '再計算を起動させる
End Sub
------------------------------ 
Sub TKGM_syuukei()   '回号、番号間隔、を出力。
Dim j, k, i, n, nn, caunter, Maxx, setretu, span, writretu, kaigo, start, gyou As Integer
start = MsgBox("集計を開始しますか?", vbYesNo)
If start = vbNo Then End
   Sheets("原本").Select
    caunter = 0
   Range("gr7:lg5000").ClearContents '出力表示部のクリア
Call saikeisanon
    kaigo = Range("l1")
  Range("gi10") = "=CL3 " 'データを参照する
  Range("gj10") = "=CN3 "
  Range("gk10") = "=DG3 "
  Range("gl10") = "=DA3 "
  Range("gm10") = "=DB3 "
  Range("gi10:gm10").Copy Range(Cells(11, 191), Cells(9 + kaigo, 195)) 'データを回号分コピー
    Range(Cells(11, 191), Cells(9 + kaigo, 195)).Select
    Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
   i = 10
Call saikeisanoff '再計算を止めて計算を速くする
Do Until Cells(i - 7, 4) = ""
  For n = 1 To 5
 Select Case n 'データ表示列位置の設定
  Case 1:  span = 200 '合計
  Case 2:  span = 240 '奇数偶数
  Case 3:  span = 260 '大小
  Case 4:  span = 280 'ミニスプラス
  Case 5:  span = 310 'ミニスぺース
 End Select
 setretu = Cells(i, 190 + n).Value '番号によりデータ記入位置を設定する。
 writretu = setretu + span
caunter = Application.CountA(Range(Cells(10, writretu), Cells(1000, writretu))) '記入位置をカウンタから計算する。
  Cells(10 + caunter, writretu) = Cells(i - 7, 4)  '番号データを5行から記入する。
  Cells(1200 + caunter, writretu) = Cells(i - 7, 1) '回号データを記入する。
If caunter = 0 Then '回号データの間隔を2300行から記入する
 Cells(2300 + caunter, writretu) = Cells(i - 7, 1)
Else
 Cells(2300 + caunter, writretu) = Abs(Cells(1200 + caunter, writretu) - Cells(1199 +   caunter, writretu))
End If
 Cells(7, writretu) = caunter + 1   '合計カウンタを計算表示する
'最終当選間隔計算
 Cells(4, writretu) = Application.Max(Range(Cells(1200, writretu), Cells(2100, writretu)))
Next n
 i = i + 1
   If i = 5000 Then Exit Do
Loop
 Cells(kaigo + 9, 190).Select
 gyou = ActiveCell.Row
 Cells(kaigo + 9, 190) = gyou - 9
Call saikeisanon '再計算を起動させる
 Cells(kaigo + 9, 190).Select
End Sub

------------------------------ 

Sub kankaku_sita_syuukei()   ' 間隔を下並びで出力。整列コピーする準備
 
 Dim j, k, x, n, nn, caunter, Maxx, setretu, span, writretu, kaigo, startgyou, start, gyou As Integer
start = MsgBox("間隔下並び集計を開始しますか?", vbYesNo)


If start = vbNo Then End


 Sheets("原本").Select
  
caunter = 0
  
    Range("gr4500:lh7501").ClearContents '出力表示部のクリア
    Call saikeisanon
 
    kaigo = Range("l1")
      
    Range("gi10") = "=CL3 " 'データを参照する
    Range("gj10") = "=CN3 "
    Range("gk10") = "=DG3 "
    Range("gl10") = "=DA3 "
    Range("gm10") = "=DB3 "
    Range("gi10:gm10").Copy Range(Cells(11, 191), Cells(9 + kaigo, 195)) 'データを回号分コピー
   
     Range(Cells(11, 191), Cells(9 + kaigo, 195)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
     startgyou = 9 + kaigo
   Call saikeisanoff '再計算を止めて計算を速くする


For x = startgyou To 10 Step -1


  For n = 1 To 5
         
        Select Case n 'データ表示列位置の設定
           Case 1:  span = 200 '合計
           Case 2:  span = 240 '奇数偶数
           Case 3:  span = 260 '大小
           Case 4:  span = 280 'ミニスプラス
           Case 5:  span = 310 'ミニスぺース
         End Select
        setretu = Cells(x, 190 + n).Value '番号によりデータ記入位置を設定する。
          
        writretu = setretu + span
         caunter = Application.CountA(Range(Cells(4500, writretu), Cells(5500, writretu)))  
   
   '記入位置をカウンタから計算する。
    
        Cells(5501, writretu) = caunter
   
     If caunter = 0 Then '回号データを5500行から記入し間隔を表示する
        Cells(5500, writretu) = Cells(x, 190)
        Cells(5502, writretu) = kaigo - Cells(5500, writretu)
     Else
        Cells(5500 - caunter, writretu) = Cells(x, 190)
        If caunter = 1 Then
          Cells(5500, writretu) = Cells(5500, writretu) - Cells(5500 - caunter, writretu)
        ElseIf caunter >= 2 Then
          Cells(5501 - caunter, writretu) = Cells(5501 - caunter, writretu) - Cells(5500 - caunter, writretu)
        End If
       
     End If
       
     Cells(5501, writretu) = caunter + 1   '合計カウンタを計算表示する
     Cells(5504, writretu) = kaigo - Cells(5502, writretu)
    Next n
Next x


Cells(5501, 320) = 5501 - Application.Max(Range(Cells(5501, 200), Cells(5501, 319)))
Cells(5501, 199) = "=SUM(GR5501:HS5501)"
Call saikeisanon '再計算を起動させる
Cells(kaigo + 9, 190).Select
End Sub
------------------------------------------------------------------------------------------------------------------------
Sub 整列Copi_propaty() 'Sub kankaku_sita_syuukei()で間隔を下並びで出力後シート「プロパテイ」に整列コピー
  Dim Maxx, start As Integer
  start = MsgBox("「各間隔データ集計」を「プロパテイ」にコピーしますか?", vbYesNo)
   
 Call saikeisanoff '再計算を止めて計算を速くする・
If start = vbNo Then End
   Sheets("プロパテイ").Select


    Sheets("原本").Select '合計
 
          Maxx = Cells(5501, 320)
  
     Range(Cells(Maxx, 209), Cells(5500, 223)).Select


     Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("C16").Select
 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
   '-----------------------------------------------------------
        Sheets("原本").Select '奇数偶数
     Range(Cells(Maxx, 241), Cells(5500, 248)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("C43").Select
  
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    '----------------------------------------------------------
    Sheets("原本").Select '大小
          Range(Cells(Maxx, 261), Cells(5500, 268)).Select
         Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
 
    Range("C53").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
       
    '----------------------------------------------------------
        Sheets("原本").Select 'ミニプラス
      Range(Cells(Maxx, 280), Cells(5500, 298)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
  
    Range("C64").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
   '-----------------------------------------------------------
    Sheets("原本").Select 'ミニスペース
       Range(Cells(Maxx, 310), Cells(5500, 319)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("c87").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
     Cells(1, 1) = Sheets("原本").Cells(1, 197)
    
     '******************************
     
     '前回当選からの間隔
    
      Sheets("原本").Select
    Range("GV5502:HO5502").Select
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("BCE16").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
       
    Sheets("原本").Select
  
    Range("IG5502:IN5502").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
 
    Range("BCE43").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
 
    Sheets("原本").Select
    Range("JA5502:JH5502").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("BCE53").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
  
    Sheets("原本").Select
  
    Range("JT5502:KL5502").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("BCE64").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
  
    Sheets("原本").Select
   
    Range("KX5502:LG5502").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("プロパテイ").Select
    Range("BCE87").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
   Call saikeisanon '再計算
      Range("a3").Select
End Sub

------------------------------ 
 Sub next_3total() '次合計を表示する
Sheets("次数字").Select
Range("io12:jp6000").ClearContents '出力表示部のクリア
Call saikeisanoff '再計算を止めて計算を速くする・
   Sheets("原本").Select
   las10 = Cells(1, 12)
   Range("CL3:CL5000").Select
   Range(Cells(3, 90), Cells(3 + las10, 90)).Select
   Selection.Copy
   Sheets("次数字").Select
   Range("IM15").Select
   ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = 15
Do Until Cells(i, 247) = ""
 retu_1 = Cells(i, 247).Value + 249
 nextotal = Cells(i + 1, 247)
  caunter = Application.Count(Range(Cells(15, retu_1), Cells(500, retu_1))) + 1
 Cells(13, retu_1) = caunter
 Cells(caunter + 15, retu_1) = nextotal
 i = i + 1
 If i = 4001 Then Exit Do
Loop
  Call saikeisanon '再計算をオンにする・
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub nextsuuji_3keta() '桁別次数字を表示する
Dim retu_1, jisyyji, h, j, i As Integer
  start = MsgBox("開始しますか?", vbYesNo)
  If start = vbNo Then End
  Sheets("次数字").Select
    Range("dv12:ey6000").Clear '出力表示部のクリア
    Application.ScreenUpdating = False '画面変更オフ
 Sheets("原本").Select
    Range("E3:G5000").Select
    Selection.Copy
 Sheets("次数字").Select
Range("DR12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Call saikeisanoff '再計算を止めて計算を速くする
i = 12: caunter = 0
Do Until Cells(i, 123) = ""
 For j = 1 To 3
  Select Case j 'データ表示列位置の設定
   Case 1:  span = 126: h = 0 '百桁
   Case 2:  span = 136: h = 1 '十桁
   Case 3:  span = 146: h = 2 '一桁
  End Select
  retu_1 = 0
  retu_1 = Cells(i, 122 + h).Value + span
  jisyyji = Cells(i + 1, 122 + h)
  caunter = Application.Count(Range(Cells(12, retu_1), Cells(500, retu_1))) + 1
  Cells(10, retu_1) = caunter
  Cells(caunter + 11, retu_1) = jisyyji
 Next j
  i = i + 1
  If i = 5001 Then Exit Do
Loop
Call saikeisanon '再計算をオンにする
Application.ScreenUpdating = True '画面変更on
Range("Dv11").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub nextketa_seiretu()   '桁別次数字を下並び出力表示する
Dim gokei_max As Integer
Dim i, ii, j, jj, k, start As Integer
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
   Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(8, 126)
For i = 0 To 30
 motosuu = Cells(10, i + 126)
 Range(Cells(12, i + 126), Cells(12 + motosuu, i + 126)).Select '番号,
 Selection.Cut
 Cells(12 + gokei_max - motosuu, i + 126).Select
 ActiveSheet.Paste
Next i
Call saikeisanon '再計算を起動させる
End Sub
------------------------------ 
Sub nextotal_seiretu()   '番号,回号、間隔を下並び出力。
 Dim gokei_max As Integer
 Dim i, ii, j, jj, k, start As Integer
 Sheets("次数字").Select
   start = MsgBox("整列開始しますか?", vbYesNo)
   If start = vbNo Then End
   Call saikeisanoff '再計算を止めて計算を速くする
  gokei_max = Cells(10, 248)
For i = 0 To 27
  motosuu = Cells(13, i + 249)
  Range(Cells(16, i + 249), Cells(16 + motosuu, i + 249)).Select '番号,
  Selection.Cut
  Cells(16 + gokei_max - motosuu, i + 249).Select
  ActiveSheet.Paste
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub kiguu3_tyusyutu()
  Dim kai, i, ii, r, t, span, owari As Integer
Sheets("すとれ-と").Select
 i = 4
 Cells(3, 354) = Empty
 kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
 If kai = False Or kai = "" Then End
 Range("mf4:mh5000,mp4:mw5000").ClearContents
 owari = Cells(2, 13) + kai
 Cells(3, 354) = kai
 Call saikeisanoff '再計算を止めて計算を速くする
 Do Until Cells(i, 4) = ""
  For x = 0 To 2
 If Cells(i, 4 + x) / 2 = Int(Cells(i, 4 + x) / 2) Then
  Cells(i, 344 + x) = 0
 Else
  Cells(i, 344 + x) = 1
 End If
 Next x
  i = i + 1
  If i > 5000 Then Exit Do
Loop
i = 4
For ii = 0 To owari Step kai
 For r = 0 To 2
  Select Case r '百,十,一,のデータ表示列位置の設定
   Case 0: span = 355 '百
   Case 1: span = 357 '十
   Case 2: span = 359 '一  
  End Select
Cells(i, span) = Application.CountIf(Range(Cells(4 + ii, r + 344), Cells(ii + kai + 3, r +   344)), 1)
Cells(i, span + 1) = Application.CountIf(Range(Cells(4 + ii, r + 344), Cells(ii + kai + 3, r + 344)), 0)
Next r
 If ii > 0 Then Cells(i - 1, 354) = ii
 i = i + 1
Next ii
 Call saikeisanon
End Sub
------------------------------ 
Sub 大小3_tyusyutu()
 Dim kai, i, ii, r, t, span, owari As Integer
 Sheets("すとれ-と").Select
 i = 4
 Cells(3, 374) = Empty
 kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
 If kai = False Or kai = "" Then End
Range("mj4:ml5000,nj4:np5000").ClearContents
  owari = Cells(2, 13) + kai
  Cells(3, 474) = kai
Call saikeisanoff '再計算を止めて計算を速くする
Do Until Cells(i, 4) = ""
 For x = 0 To 2
  If Cells(i, 4 + x) < 5 Then
 Cells(i, 348 + x) = 0
  Else
 Cells(i, 348 + x) = 1
  End If
 Next x
   i = i + 1
 If i > 5000 Then Exit Do
Loop
i = 4
For ii = 0 To owari Step kai
 For r = 0 To 2
  Select Case r '千、百,十,一,のデータ表示列位置の設定
   Case 0: span = 375 '千百
   Case 1: span = 377 '千百
   Case 2: span = 379 '千十
  End Select
 Cells(i, span) = Application.CountIf(Range(Cells(4 + ii, r + 348), Cells(ii + kai + 3, r + 348)), 1)
Cells(i, span + 1) = Application.CountIf(Range(Cells(4 + ii, r + 348), Cells(ii + kai + 3, r + 348)), 0)
Next r
 If ii > 0 Then Cells(i - 1, 374) = ii
 i = i + 1
Next ii
 Call saikeisanon
End Sub
------------------------------ 

Sub hotnum3_color() 'ホットナンバー色付け 同時に3ヶ所を行う
Dim maruiti As Range
Dim gyou, retu, stretu, deme As Integer


Worksheets("原本").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu = 5 Then stretu = 16
If retu = 6 Then stretu = 26
If retu = 7 Then stretu = 36
deme = Cells(gyou, retu)          
If retu <= 4 Or retu >= 8 Then End
deme_iti = Cells(gyou, retu) + 77


If Cells(gyou, retu) > 4 Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With   
End If


Set maruiti = Application.Cells(gyou, deme_iti)    
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 53 


If retu = 6 Or retu = 7 Then 
Cells(gyou, retu + 95).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With 
End If


Worksheets("すとれ-と").Select
Cells(gyou + 1, deme + stretu).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Underline = xlUnderlineStyleSingle
Worksheets("原本").Select 
Cells(gyou, retu + 164) = Cells(gyou, retu) 


j = 1     


Do Until Cells(gyou + j, retu) = deme  
If j > 3 Then Exit Do
j = j + 1
Loop
Cells(gyou + j, retu).Select        
End Sub




2.No.3 分析

Sub pear_suji()   'ペアストレート数字百十、百一、十一に別に回号、間隔、番号を出力。
Dim j, k, i, Maxx, yretu, loopend As Integer
Worksheets("二桁").Range("a21").Select
kaigo = Worksheets("原本").Cells(1, 12).Value
Sheets("二桁").Select
Cells(18, 2) = kaigo
loopend = kaigo + 50
 Range("r21:ms1000").ClearContents '出力表示部のクリア
Call saikeisanon
Range("n21") = "=CONCATENATE(原本!E3,原本!F3)"
Range("o21") = "=CONCATENATE(原本!E3,原本!G3)"
Range("p21") = "=CONCATENATE(原本!F3,原本!G3)"
Range("n21:p21").Copy Range(Cells(22, 14), Cells(50 + kaigo, 16))
Call saikeisanoff '再計算を止めて計算を速くする
i = 21
yretu = 0
Do Until Cells(i, 14) = ""
Cells(i, 13) = i - 20 '計算の為の回号表示する。
 For n = 1 To 3 '百十、百一、十一に分ける。
   setretu = Cells(i, 13 + n).Value '当選番号によりデータ記入位置を設定する。
       Select Case n '百十、百一、十一のデータ表示列位置の設定
     Case 1: span = 0 '百十
           Case 2: span = 120 '百一
          Case 3: span = 240 '十一
      End Select
yretu = 18 + setretu + span
caunter = Application.CountA(Range(Cells(21, yretu), Cells(120, yretu))) '記入位置をカウンタから計算する。
   Cells(21 + caunter, yretu) = Cells(i, 13) '回号データを記入する。
 If caunter = 0 Then '回号データの間隔を150行から記入する
 Cells(150 + caunter, yretu) = Cells(i, 13)
Else
 Cells(150 + caunter, yretu) = Abs(Cells(20 + caunter, yretu) - Cells(21 + caunter, yretu))
End If
Cells(i, 359) = Cells(i, 16) 'ミニ
Cells(i, 360) = Cells(150 + caunter, yretu) 'ミニ間隔
Cells(250 + caunter, yretu) = Worksheets("原本").Cells(i - 18, 4)  '番号データをを250行から記入する。
  Cells(19, yretu) = caunter + 1 '合計カウンタを計算表示する
If kaigo = Cells(i, 13) Then
For k = 1 To 100 '最終当選間隔計算
Maxx = kaigo - Application.Max(Range(Cells(21, 17 + k + span), Cells(74, 17 + k + span)))
Cells(18, 17 + k + span) = Maxx
Next k
End If
  Next n
i = i + 1
If i = loopend Then Exit Do
Loop
Range("R18:DM19").Select 'まとめてコピーする。自動記録マクロで作成
Selection.Copy
Range("B23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
   Range("EH18:IC19").Select
Application.CutCopyMode = False
Selection.Copy
Range("F23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
    Range("IX18:MS19").Select
Application.CutCopyMode = False
Selection.Copy
Range("J23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveWindow.ScrollColumn = 13
Range("B20").Select
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub pear_suji_seiretu()   'ペアストレート数字百十、百一、十一に別に回号、間隔、番号を下並びで整列して出力。時間が掛かるw
Dim j, k, i, Maxx, n, nn As Integer
 Sheets("二桁").Select
   Call saikeisanoff '再計算を止めて計算を速くする
 i = 21
For n = 1 To 3 '百十、百一、十一に分ける。
setretu = Cells(i, 13 + n).Value '番号によりデータ記入位置を設定する。
   Select Case n '百十、百一、十一のデータ表示列位置の設定
   Case 1: span = 18 '百十
     Case 2: span = 138 '百一
    Case 3: span = 258 '十一     
End Select
    Maxx = Application.Max(Range(Cells(19, span), Cells(19, span + 100)))
For nn = 0 To 99
  motosuu = Cells(19, nn + span)
  If Cells(19, 18) = "" Then End
If Maxx > motosuu Then
  Range(Cells(21, nn + span), Cells(Maxx - motosuu + 20, nn + span)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
 Next nn
Next n
Range("q21").Select
Call 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
   setretu = Cells(i, 2).Value
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
   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 nmbers3()'クイックピック
Randomize
Range("a1:b10").Select
Selection.ClearContents
count_5 = 0
For i = 1 To 3
    kai = Int(Rnd() * 10)
 Cells(i, 1) = kai
    Range("c1") = "=count(a1:a10)"
Next i
Range("g10:i10") = kai
   Range("A1:A3").Select
Selection.Copy
Range("G10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub mini_kankaku() 'ミニ、間隔、回号記入、太字にする
     Dim moji As Range
     Dim  gosel As Integer

      gosel = Cells(18, 2).Value
       Range("MW25").Select
      Selection.Copy
      Range(Cells(26, 361), Cells(gosel + 20, 361)).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
       
     Cells(gosel + 20, 360).Select
      retu = ActiveCell.Column
      gyou = ActiveCell.Row
     Cells(gyou, 358) = gyou - 20
    
     If Cells(gyou, 361) = 1 Then  '記入セルを太字にする
      Set moji = Application.Cells(gyou, 362)
      moji.Font.Bold = True
     Else
      Set moji = Application.Cells(gyou, 363)
        moji.Font.Bold = True
     End If
        
End Sub

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 下揃え()
    Range("D2:D6").Select
Selection.Cut
Range("D6").Select
ActiveSheet.Paste
End Sub
---------------------------------------------------------------------------
Sub pear_suuji_3()   'ペア数字
j = 0
i = 21
k = 0
d = 0
Sheets("二桁").Select
patann = 0
Call saikeisanon
Range("ns21:pu5000").ClearContents
kaigo = Worksheets("原本").Cells(1, 12).Value
Range("nm21") = "=LEFT(原本!CO3,2)"
Range("nn21") = "=LEFT(原本!CO3,1)&RIGHT(原本!CO3,1)"
Range("no21") = "=RIGHT(原本!CO3,2)"
Range("nm21:no21").Copy Range(Cells(22, 377), Cells(20 + kaigo, 379))
  Call saikeisanoff
Do Until Cells(i, 377) = ""
    For j = 1 To 3 '出目の入力348
      d = Cells(i, j + 376).Value
If d >= 0 And d <= 9 Then
   k = 1
ElseIf d >= 11 And d <= 19 Then
 k = 0
ElseIf d >= 22 And d <= 29 Then
  k = -2
ElseIf d >= 33 And d <= 39 Then
  k = -5
ElseIf d >= 44 And d <= 49 Then
  k = -9
ElseIf d >= 55 And d <= 59 Then
  k = -14
ElseIf d >= 66 And d <= 69 Then
  k = -20
ElseIf d >= 77 And d <= 79 Then
  k = -27
ElseIf d >= 88 And d <= 89 Then
  k = -35
ElseIf d = 99 Then
k = -44
Else
k = 0
End If
  Cells(i, 382 + k + d) = Cells(i, 376 + j)
Next j
    i = i + 1
    If i = 4001 Then Exit Do
Loop
Call saikeisanon
  Range("ns6").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub nextnumber()'桁別の次回の番号表示する。
Dim nenum(3) As String
Dim stopnum As Integer
Call saikeisanon
  Sheets("次数字").Select
kaigo = Application.InputBox("開始回号番号入力して下さい")
If kaigo <= 0 Then End
kaigo = kaigo + 11
Range(Cells(kaigo, 6), Cells(kaigo + 2000, 105)).ClearContents '出力表示部のクリア
    With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
stopnum = Cells(10, 1) + 1
Range("e12").Select
Range("b12") = "=原本!E3&原本!E4"
Range("c12") = "=原本!f3&原本!f4"
Range("d12") = "=原本!g3&原本!g4"
Range("e12") = "=原本!d4"
Range("b12:e12").Copy Range(Cells(13, 2), Cells(stopnum + 10, 5))
  Call saikeisanon
    i = kaigo
Call saikeisanoff '再計算を止めて計算を速くする
Do Until Cells(i, 1) = stopnum
For n = 1 To 3 '百十一に分ける。
  setretu = Cells(i, 1 + n).Value '番号によりデータ記入位置を設定する。
  Cells(i, setretu + 6) = Cells(i, 1 + n)
  nenum(n) = Cells(i, 1 + n)
If n = 1 Then
Cells(i, setretu + 6).Select
With Selection.Font
.Color = -16776961
  End With
ElseIf n = 2 Then
Cells(i, setretu + 6).Select
With Selection.Font
.Color = -11489280
  End With
If nenum(n - 1) = nenum(n) Then
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
End With
End If
Else
Cells(i, setretu + 6).Select
With Selection.Font
.ThemeColor = xlThemeColorAccent6
End With
If nenum(n - 1) = nenum(n) Or nenum(n - 2) = 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 '再計算をオンにする
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー