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

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

3.N4プロパティ分析


Sub 二桁毎の各種分析()
'マクロ記録で作成
    Range("B3:X104").Select
Selection.Copy
Range("B150").Select
ActiveSheet.Paste
Range("B260").Select
ActiveSheet.Paste
Range("B152:D251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("C152:C251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("B152:D251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("F152:H251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("G152:G251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("F152:H251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J152:L251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("K152:K251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("J152:L251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
  Range("N152:P251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("O152:O251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("N152:P251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
    Range("R152:T251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("S152:S251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("R152:T251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With  
Range("V152:X251").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("W152:W251") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("V152:X251")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=25
Range("B262:D361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("D262:D361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("B262:D361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-82
Range("F262:H361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("H262:H361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("F262:H361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-79
Range("J262:L361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("L262:L361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("J262:L361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-80
Range("N262:P361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("P262:P361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("N262:P361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.LargeScroll Down:=-3
Range("R262:T361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("T262:T361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("R262:T361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.LargeScroll Down:=-3
Range("V262:X361").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("X262:X361") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("V262:X361")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
  Range("B152").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub そ_と千一() ’千百から十一までの2桁毎の未出間隔並び替え
saikeisanoff
Range("B152:D251").Select
Selection.Copy
Range("Z151").Select
ActiveSheet.Paste
Range("AC151").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1100"
Range("AC151").Select
Selection.AutoFill Destination:=Range("AC151:AC250")
Range("AC151:AC250").Select
Range("F152:H251").Select
Selection.Copy
Range("Z251").Select
ActiveSheet.Paste
Range("AC251").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1010"
Range("AC251").Select
Selection.AutoFill Destination:=Range("AC251:AC350")
Range("AC251:AC350").Select
  Range("J152:L251").Select
Selection.Copy
ActiveWindow.LargeScroll Down:=4
Range("Z351").Select
ActiveSheet.Paste
Range("AC351").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1001"
Range("AC351").Select
Selection.AutoFill Destination:=Range("AC351:AC450")
Range("AC351:AC450").Select
Range("N152:P251").Select
Selection.Copy
Range("Z451").Select
ActiveSheet.Paste
Range("AC451").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "110"
Range("AC451").Select
Selection.AutoFill Destination:=Range("AC451:AC550")
Range("AC451:AC550").Select
Range("R152:T251").Select
Selection.Copy
Range("Z551").Select
ActiveSheet.Paste
Range("AC551").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "101"
Range("AC551").Select
Selection.AutoFill Destination:=Range("AC551:AC650")
Range("AC551:AC650").Select
Range("V152:X251").Select
Selection.Copy
Range("Z651").Select
ActiveSheet.Paste
Range("AC651").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "11"
Range("AC651").Select
Selection.AutoFill Destination:=Range("AC651:AC750")
Range("AC651:AC750").Select
Range("AE651").Select
   Range("Z151:AC750").Select
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("AA151:AA750" _
), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("桁分析").Sort.SortFields.Add Key:=Range("AB151:AB750" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("桁分析").Sort
.SetRange Range("Z151:AC750")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
saikeisanon
Range("Z151").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 非表示()
    Rows("3:11").Select
Selection.EntireRow.Hidden = True
Rows("31:39").Select
Selection.EntireRow.Hidden = True
End Sub
----------------
Sub 表示()
Rows("30:40").Select
Selection.EntireRow.Hidden = False
Rows("2:12").Select
Selection.EntireRow.Hidden = False
End Sub
--------------------------------------------------------------------------------------------------------
Sub 月曜日()
retu = ActiveCell.Column
gyou = ActiveCell.Row
     Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleDouble
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 木曜日()
retu = ActiveCell.Column
gyou = ActiveCell.Row
Selection.Font.Bold = True
    Selection.Font.Underline = xlUnderlineStyleSingle
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 大小へ()
    ActiveWindow.SmallScroll ToRight:=165
End Sub


Sub 合計へ()
   ActiveWindow.SmallScroll ToRight:=-400
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub Boxx_Kensaku()
On Error GoTo errorcheck
'Static maeban
maeban = Cells(1, 1)
Range("B2:b1430").Select
bango = Application.InputBox("BOX番号入力して下さい", Default:=maeban)
maeban = bango
Cells(1435, 1) = maeban
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
retu = ActiveCell.Column
gyou = ActiveCell.Row
Range(Cells(gyou, retu), Cells(gyou, retu)).Select
i = 0
Do Until Cells(gyou, 2 + i) = ""
i = i + 1
Range(Cells(gyou, 2 + i), Cells(gyou, 2 + i)).Select
If i = 40 Then Exit Do
Loop
Exit Sub
errorcheck:
MsgBox "エラー番号" & Err & ":" & Error(Err): End  
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ストレート入力() '番号入力
     Dim n_re, gyou, retu, Start, kai As Integer
      Dim st_no As String
          saikeisanoff
        st_no = Sheets("奇遇").Cells(1, 1)
        Sheets("box").Select
           
           gyou = ActiveCell.Row
           retu = ActiveCell.Column
        
           kai = retu - 3
        
          Start = MsgBox(st_no & "で入力しますか?", vbYesNo)
          If Start = vbNo Then End   
           If Cells(gyou, retu) = "" Then Cells(gyou, retu) = st_no
      
          For r = 3 To k Step 2
            If Cells(gyou, r) = st_no Then
               Cells(gyou, retu).Select
            
              Call color_set
              Exit For
           
            End If
         
          Next r
      
      saikeisanon
             Cells(gyou, retu).Select
   End Sub

2.N4プロパティ分析

Sub copytotal()
gyou = ActiveCell.Row
iti = Cells(gyou, 2)
kankaku_gk = Cells(gyou - 1, 4 + iti)
If kankaku_gk = "●" Then kankaku_gk = 0
  Range(Cells(gyou, 4), Cells(gyou, 40)).Select
   Selection.Copy
Sheets("結果まとめ").Select
Range("ms3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms12:ms30").Select
    Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(40, 357) = kankaku_gk
i = 0
Cells(iti + 3, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(iti + 3, 356 - i) <> "" '間隔記入位置を決める
Cells(iti + 3, 356 - i).Select
i = i + 1
  Loop
Cells(iti + 3, 357 - i) = kankaku_gk '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub copykiguu()
gyou = ActiveCell.Row
If gyou <= 3 Then End
If Cells(gyou, 4) = "" Then End
iti = Cells(gyou, 2) '奇遇タイプ
kankaku_kg = Cells(gyou - 1, 3 + iti) '間隔を把握する
If kankaku_kg = "●" Then kankaku_kg = 0
Range(Cells(gyou, 4), Cells(gyou, 19)).Select
Selection.Copy
Sheets("結果まとめ").Select
Range("ms46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms46:ms61").Select
    Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(45, 357) = kankaku_kg
Cells(iti + 45, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(iti + 45, 356 - i) <> "" '間隔記入位置を決める
Cells(iti + 45, 356 - i).Select
i = i + 1
  Loop
Cells(iti + 45, 357 - i) = kankaku_kg '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub copysb()
Dim sbiti As Integer
gyou = ActiveCell.Row
If gyou <= 4 Then End
If Cells(gyou, 168) = "" Then End
sbiti = Cells(gyou, 167)
kankaku_sb = Cells(gyou - 1, sbiti + 167)
If kankaku_sb = "●" Then kankaku_sb = 0
Range(Cells(gyou, 168), Cells(gyou, 183)).Select
Selection.Copy
Sheets("結果まとめ").Select
Range("ms65").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms65:ms80").Select
    Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(64, 357) = kankaku_sb
     i = 0
Cells(sbiti + 64, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(sbiti + 64, 356 - i) <> "" '間隔記入位置を決める
Cells(sbiti + 64, 356 - i).Select
i = i + 1
Loop
Cells(sbiti + 64, 357 - i) = kankaku_sb  '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
 Sub 縦揃え()
Dim datas(300) As Integer
      retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
Do Until retu - i = 2
If Cells(gyou, retu - i) <> "" Then
datas(i - j + 1) = Cells(gyou, retu - i)
End If
If retu = 1 Then Exit Do
i = i + 1: k = i
j = j + 1
Loop
For i = 1 To k
Cells(100, retu - i + 1) = datas(i)
Next i
  End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub color_set()
  Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 桁集計()
 Call saikeisanoff
    Sheets("千百分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
ActiveWindow.SmallScroll Down:=113
Range("Z130").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("千十分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z132").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("千一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z134").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("百十分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z136").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("百一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z138").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("十一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z140").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Call saikeisanon
kaigot = 0
For k = 1 To 12 Step 2 '130 133
kaigot = kaigot + Cells(k + 129, 26)
Next k
  If Cells(130, 26) <> kaigot / 6 Then MsgBox ("入力ミスがあります")
Range("Z130").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Boxx_Kensaku()
On Error GoTo errorcheck
'Static maeban
maeban = Cells(1, 1)
Range("B2:b1430").Select
bango = Application.InputBox("BOX番号入力して下さい", Default:=maeban)
maeban = bango
Cells(1435, 1) = maeban
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
retu = ActiveCell.Column
gyou = ActiveCell.Row
Range(Cells(gyou, retu), Cells(gyou, retu)).Select
i = 0
Do Until Cells(gyou, 2 + i) = ""
i = i + 1
Range(Cells(gyou, 2 + i), Cells(gyou, 2 + i)).Select
If i = 40 Then Exit Do
Loop
Exit Sub
errorcheck:
MsgBox "エラー番号" & Err & ":" & Error(Err): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去()
'飛び期間の空行を詰めて表示する。

Dim x, i, k, retu_1, retu_2 As Integer
      actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then '元データをコピーする。
Range("av5:bk1000").ClearContents
retu_1 = 28: retu_2 = 47
ElseIf actsheet = "合計" Then
Range("gw5:hl800").Select
Selection.ClearContents
retu_1 = 185: retu_2 = 204
Else
End
End If
saikeisanoff
For x = 1 To 16
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, retu_1 + x) <> "" Then
Cells(5 + i - k, retu_2 + x).Value = Cells(5 + i, retu_1 + x).Value
Else
k = k + 1
End If
           If i = 5000 Then Exit Do
i = i + 1
Loop
Next x
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去_2()
'飛び期間の空行を詰めて表示する。
Dim x, i, k, retu_1, retu_2 As Integer
      actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then '元データをコピーする。
Range("av5:bk800").ClearContents
retu_1 = 4: retu_2 = 47
ElseIf actsheet = "合計" Then
Range("gw5:hl800").Select
Selection.ClearContents
retu_1 = 185: retu_2 = 204
Else
End
End If
saikeisanoff
For x = 1 To 16
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, retu_1 + x) = "●" Then
Cells(5 + i - k, retu_2 + x).Value = Cells(5 + i, retu_1 + x).Value
Else
k = k + 1
End If
           If i = 5000 Then Exit Do
i = i + 1
Loop
Next x
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去整列()  
Dim gokei_max As Integer
Dim i, ii, j, jj, k, start As Integer
actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then
retu_2 = 47
frg = 48
ElseIf actsheet = "合計" Then
retu_2 = 204
frg = 205
Else
End
End If
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(2, retu_2)
For i = 1 To 16
motosuu = Cells(2, i + retu_2)
'If Cells(9, 110) = "" Then End
Range(Cells(5, i + retu_2), Cells(5 + motosuu, i + retu_2)).Select '番号
Selection.Cut
Cells(5 + gokei_max - motosuu, i + retu_2).Select
ActiveSheet.Paste
Next i
Range(Cells(5, frg), Cells(gokei_max + 4, frg + 15)).Select
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 奇偶整列()  
Dim kigu_max As Integer
Dim i, ii, j, jj, k, start As Integer
If Cells(5, 48) = Empty Then End
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
kigu_max = Cells(2, 47)
For i = 1 To 16
motosuu = Cells(2, i + 47)
'If Cells(9, 110) = "" Then End
Range(Cells(5, i + 47), Cells(5 + motosuu, i + 47)).Select '番号
Selection.Cut
Cells(5 + kigu_max - motosuu, i + 47).Select
ActiveSheet.Paste
Next i
Range(Cells(5, 48), Cells(gokei_max + 4, 63)).Select
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 合計空行除去()
'飛び期間の空行を詰めて表示する。
 Dim x, i, k As Integer
  Sheets("合計").Select
Range("cg5:dq800").ClearContents
saikeisanoff
For x = 1 To 36
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, 44 + x) <> "" Then
Cells(5 + i - k, 84 + x).Value = Cells(5 + i, 44 + x).Value
Else
k = k + 1
End If
           If i = 5000 Then Exit Do
i = i + 1
Loop
Next x
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 合計整列()  
Dim gokei_max As Integer
Dim i, ii, j, jj, k, start As Integer
Sheets("合計").Select
 If Cells(5, 110) = "" Then End
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
   Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 80)
For i = 1 To 35
motosuu = Cells(3, i + 85)
'If Cells(9, 110) = "" Then End
Range(Cells(5, i + 85), Cells(5 + motosuu, i + 85)).Select '番号
Selection.Cut
Cells(5 + gokei_max - motosuu, i + 85).Select
ActiveSheet.Paste
Range(Cells(5, 94), Cells(gokei_max + 4, 112)).Select
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 大小整列()  
Dim daisyo_max As Integer
Dim i, ii, j, jj, k, start, motosuu As Integer
Sheets("合計").Select
If Cells(5, 211) = "" Then End
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
   Call saikeisanoff '再計算を止めて計算を速くする
daisyo_max = Cells(1, 220)
For i = 1 To 16
motosuu = Cells(2, i + 204)
    Range(Cells(5, i + 204), Cells(5 + motosuu, i + 204)).Select '番号
Selection.Cut
Cells(5 + daisyo_max - motosuu, i + 204).Select
ActiveSheet.Paste
Range(Cells(5, 205), Cells(daisyo_max + 4, 220)).Select
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub tobi_kikan_cunters() '飛び期間を記入する
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
  retu = ActiveCell.Column
gyou = ActiveCell.Row
i = 0
Do Until Cells(gyou + i, retu - 1) = "" And Cells(gyou + i, retu) = ""
If Cells(gyou + i, retu) = "" Then
       Cells(gyou + i, retu) = k + 1
k = k + 1
If Cells(gyou + i + 1, retu) <> "" Then k = 0
End If
  If i = 4001 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 頭へ()
ActiveWindow.ScrollRow = 1
End Sub


Sub boxへ()
Sheets("box").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Seiretu_peace()
 Dim prodata(500)
 Sheets("結果まとめ").Select
 ActiveWorkbook.PrecisionAsDisplayed = False
 saikeisanoff
 retu_1 = ActiveCell.Column
 gyou = ActiveCell.Row
 Range("C62:Mr120").Select
Selection.ClearContents
     Range("C3:mr120").Select
 Selection.Copy
 Range("C65").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 i = 1
 Do Until Cells(gyou, retu_1 - i) <> ""
 'Cells(gyou, retu_1 - i).Select
 i = i + 1
 If i > 500 Then Exit Do
 Loop
 Cells(gyou, retu_1 - i).Select
 retu_2 = ActiveCell.Column
   j = 0
 Do Until Cells(gyou, retu_2 - j) = ""
 Cells(gyou, retu_2 - j).Select
 prodata(j) = Cells(gyou, retu_2 - j)
 j = j + 1
 If j > 500 Then Exit Do
 Loop
 For h = 0 To j
 Cells(62, retu_1 - h) = prodata(h)
 Next h
   Range(Cells(62, 3), Cells(62, retu_1)).Select
 Selection.Copy
 Cells(gyou, 3).Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Cells(gyou, retu_1).Select
 saikeisanon
 ActiveWorkbook.PrecisionAsDisplayed = True
 End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー



1.N4プロパティ分析

Sub 横飛び記入() '記入する行をクリックした後マクロ実行する。
 retu = ActiveCell.Column
 gyou = ActiveCell.Row
For i = 0 To 20
  If Cells(gyou, retu + i) <> "" Then End
 If Cells(gyou - 1, retu + i) = "●" Then
   Cells(gyou, retu + i) = 1
 Else
   Cells(gyou, retu + i) = Cells(gyou - 1, retu + i) + 1
 End If
 If Cells(gyou - 1, retu + i + 1) = "" Then Exit For
Next i
End Sub
-------------------------------------------------------------------------------------------------

Sub allpaint_100() '当選間隔で00-99まで塗りつぶし
 saikeisanoff
For i = 1 To 100
  h = 1
 Do Until Cells(3 + h, i + 10) = ""
  If h = 1 Then
   hani = Cells(3 + h, i + 10)
  Else
   hani = Cells(3 + h, i + 10) - Cells(3 + h - 1, i + 10)
  End If
  If hani <= 50 Then ’当選間隔50回以下
   Cells(3 + h, i + 10).Select
   Selection.Font.ColorIndex = 10 '緑4
  ElseIf hani > 50 And hani <= 100 Then
   Cells(3 + h, i + 10).Select
   Selection.Font.ColorIndex = 1 '青53=茶黒1
  ElseIf hani >= 101 And hani <= 300 Then
   Cells(3 + h, i + 10).Select
   Selection.Font.ColorIndex = 3 '赤
  ElseIf hani > 300 Then
   Cells(3 + h, i + 10).Select
   Selection.Font.ColorIndex = 3 '赤
   Selection.Font.Bold = True
   Selection.Font.Underline = xlUnderlineStyleSingle
  End If
   lashani = Cells(3 + h, i + 10)
  h = h + 1
   Cells(100, i + 10) = lashani
  If h = 65 Then Exit Do
 Loop
Next i
Cells(4, 11).Select
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hanntei2_100()
 For i = 1 To 100
  h = 1
 Do Until Cells(3 + h, i + 111) = ""
  If h = 1 Then
   hani = Cells(3 + h, i + 111)
  Else
   hani = Cells(3 + h, i + 111) - Cells(3 + h - 1, i + 111)
  End If
  If hani <= 50 Then
   Cells(3 + h, i + 111).Select
   Selection.Font.ColorIndex = 50 '緑
  ElseIf hani > 50 And hani <= 100 Then
   Cells(3 + h, i + 111).Select
   Selection.Font.ColorIndex = 1 '黒1青5
  Else
   Cells(3 + h, i + 111).Select
   Selection.Font.ColorIndex = 3 '赤
  End If
  lashani = Cells(3 + h, i + 111)
   h = h + 1
  If h = 30 Then Exit Do
 Loop
Next i
 Cells(2, 111).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub cunters() '飛び期間を記入する
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
retu = ActiveCell.Column
gyou = ActiveCell.Row
i = 0
Do Until Cells(gyou + i, retu - 1) = "" And Cells(gyou + i, retu) = ""
If Cells(gyou + i, retu) = "" Then
 Cells(gyou + i, retu) = k + 1
k = k + 1
If Cells(gyou + i + 1, retu) <> "" Then k = 0
End If
  If i = 4000 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空白除去()
retu = ActiveCell.Column
gyou = ActiveCell.Row
t_w = 44
i = 0: k = 0
Do Until Cells(gyou + i, 2) = ""
If Cells(gyou + i, retu) <> "" Then
       Cells(gyou + i - k, retu + t_w) = Cells(gyou + i, retu)
Else
k = k + 1
End If
 If i = 5000 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub boxsort()
' マクロ記録日 : 2006/12/22  
Range("BH9:BL724").Select
  Selection.Sort Key1:=Range("BJ9"), Order1:=xlAscending, Key2:=Range("BH9" _
), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortTextAsNumbers
End Sub
Sub ban_go() '判定番号位置欄に移動する
maebann = Cells(1, 8)
bango = Application.InputBox("番号入力して下さい", Default:=maebann)
start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End
If bango > 99 Or bango < 0 Then MsgBox "データ等をチェックして下さい。": End
Cells(3, bango + 11).Select
i = 0
Do Until Cells(3 + i, bango + 11) = ""
Cells(4 + i, bango + 11).Select
If i = 64 Then Exit Do
i = i + 1
Loop
'If bango < 10 Then bbango = 0 & bango Else bbango = bango
res = MsgBox(bango & " の回数記入処理実行?", vbYesNo)
Select Case res
Case vbYes
Call hanntei_100
Case vbNo
Cells(1, 1).Select: End
End Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hanntei_100()
retu = ActiveCell.Column
gyou = ActiveCell.Row
If Cells(gyou, retu) = "" And Cells(gyou - 1, retu) <> "" Then
Cells(gyou, retu) = Cells(4, 9) + 1 '回数の記入
Cells(9, 10) = gyou
Cells(10, 10) = Cells(3, retu)
Cells(11, 10) = Cells(gyou, retu) - Cells(gyou - 1, retu)
Else
End
End If
' For i = 1 To retu - 10 '100
h = 1
Do Until Cells(3 + h, retu) = ""
If h = 1 Then
hani = Cells(3 + h, retu)
Else
hani = Cells(3 + h, retu) - Cells(3 + h - 1, retu)
End If
If hani <= 50 Then
Cells(3 + h, retu).Select
Selection.Font.ColorIndex = 10 '緑4
ElseIf hani > 50 And hani <= 100 Then
Cells(3 + h, retu).Select
Selection.Font.ColorIndex = 1 '青53=茶黒1
ElseIf hani >= 101 And hani <= 300 Then
Cells(3 + h, retu).Select
Selection.Font.ColorIndex = 3 '赤
ElseIf hani > 300 Then
Cells(3 + h, retu).Select
Selection.Font.ColorIndex = 3 '赤
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
End If
    lashani = Cells(3 + h, retu)
h = h + 1
Cells(100, retu) = lashani
hh = h
If h = 65 Then Exit Do
Loop
'Next i
Call kankaku_check
Cells(2 + hh, retu).Select
    Selection.Copy
Range("i4").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(4, 11).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub kankaku_check()
Range("K1:DF1").Select
Selection.Copy
  Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("K2:DF2").Select
Selection.Copy
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("a5").Select
End Sub
------------------------------------------------------------------------------------------------


Sub 奇偶判定() '奇遇,大小等を判定する。
Dim d(4), tg As Integer, kg, kgdata, to_ban, ds_pp As String
motodate = Cells(1, 1) '当選番号
 d(1) = Val(Left(motodate, 1)) '当選番号を4つの出目に分ける
 d(2) = Val(Right(Left(motodate, 2), 1))
 d(3) = Val(Left(Right(motodate, 2), 1))
 d(4) = Val(Right(motodate, 1))
 ds_p = 0
For i = 1 To 4
  If d(i) / 2 = Int(d(i) / 2) Then kg = 2 Else kg = 1 '4つを奇遇に分ける
 If d(i) <= 4 Then '4つを大小に分ける
  ds = 2
 Else
  ds = 1
  ds_p = ds_p + ds
 End If
 tg = tg + d(i) '
 kgdata = kgdata & kg '奇遇データを1と2に分類する
 dsdata = dsdata & ds '大小データを1と2に分類する
Next i
 If kgdata = "1111" Then kgkg = 1
If kgdata = "2222" Then kgkg = 2
If kgdata = "1112" Then kgkg = 3
If kgdata = "1121" Then kgkg = 4
If kgdata = "1211" Then kgkg = 5
If kgdata = "2111" Then kgkg = 6
If kgdata = "2221" Then kgkg = 7
If kgdata = "2212" Then kgkg = 8
If kgdata = "2122" Then kgkg = 9
If kgdata = "1222" Then kgkg = 10
If kgdata = "1122" Then kgkg = 11
If kgdata = "1212" Then kgkg = 12
If kgdata = "1221" Then kgkg = 13
If kgdata = "2211" Then kgkg = 14
If kgdata = "2121" Then kgkg = 15
If kgdata = "2112" Then kgkg = 16
If dsdata = "1111" Then dsds = 1
If dsdata = "2222" Then dsds = 2
If dsdata = "1112" Then dsds = 3
If dsdata = "1121" Then dsds = 4
If dsdata = "1211" Then dsds = 5
If dsdata = "2111" Then dsds = 6
If dsdata = "2221" Then dsds = 7
If dsdata = "2212" Then dsds = 8
If dsdata = "2122" Then dsds = 9
If dsdata = "1222" Then dsds = 10
If dsdata = "1122" Then dsds = 11
If dsdata = "1212" Then dsds = 12
If dsdata = "1221" Then dsds = 13
If dsdata = "2211" Then dsds = 14
If dsdata = "2121" Then dsds = 15
If dsdata = "2112" Then dsds = 16
If ds_p = 0 Then ds_pp = "■■■■": ds_ppn = 4
If ds_p = 1 Then ds_pp = "■■■□": ds_ppn = 3
If ds_p = 2 Then ds_pp = "■■□□": ds_ppn = 2
If ds_p = 3 Then ds_pp = "■□□□": ds_ppn = 1
If ds_p = 4 Then ds_pp = "□□□□": ds_ppn = 0
Cells(1, 2) = kgkg '奇遇パターン
Sheets("合計").Cells(1, 1) = tg '合計数
Sheets("合計").Cells(2, 1) = ds_pp
Sheets("合計").Cells(3, 1) = ds_ppn
Sheets("合計").Cells(2, 41) = motodate & "合計=" & tg '当選番号と合計数
Sheets("合計").Cells(1, 166) = motodate '当選番号
Sheets("千百分析").Cells(1, 2) = motodate '当選番号
Sheets("合計").Cells(2, 166) = dsds '大小パターンを1~16に分ける
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub ●記入() '奇遇パターンに合わせて1~16に表示する。
gyou = ActiveCell.Row
Cells(gyou, 2) = Cells(1, 2)
retu = Cells(gyou, 2)
If retu = "" Then End
If retu >= 17 Then End
Cells(gyou, 3 + retu) = "●"
Cells(gyou + 1, 4).Select
Cells(4, 3 + retu).Select
Selection.Copy
Cells(gyou, 21).Select
ActiveSheet.Paste
Select Case retu
Case 1: n = 0: kgp = "△△△△"
Case 2: n = 4: kgp = "▲▲▲▲"
Case 3: n = 1: kgp = "▲△△△"
Case 4: n = 1: kgp = "▲△△△"
Case 5: n = 1: kgp = "▲△△△"
Case 6: n = 1: kgp = "▲△△△"
Case 7: n = 3: kgp = "▲▲▲△"
Case 8: n = 3: kgp = "▲▲▲△"
Case 9: n = 3: kgp = "▲▲▲△"
Case 10: n = 3: kgp = "▲▲▲△"
Case 11: n = 2: kgp = "▲▲△△"
Case 12: n = 2: kgp = "▲▲△△"
Case 13: n = 2: kgp = "▲▲△△"
Case 14: n = 2: kgp = "▲▲△△"
Case 15: n = 2: kgp = "▲▲△△"
Case 15: n = 2: kgp = "▲▲△△"
Case 16: n = 2: kgp = "▲▲△△"
End Select
  Cells(gyou, 22) = n
    Cells(gyou, 23) = kgp
  Cells(gyou + 1, 4).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub ●計記入() '合計
Sheets("合計").Select
gyou = ActiveCell.Row
Cells(gyou, 2) = Cells(1, 1)
retu = Cells(gyou, 2)
If retu = "" Then End
If Int(Cells(gyou, 2) / 2) = Cells(gyou, 2) / 2 Then
Cells(gyou, 2).Select
With Selection.Font
.Color = -16776961

End With
Else
Cells(gyou, 2).Select
With Selection.Font
.ThemeColor = xlThemeColorLight1
  End With
End If
Cells(gyou, 4 + retu) = "●"
Cells(gyou, 41) = Cells(2, 1)
Cells(gyou, 42) = Cells(3, 1)
  Cells(gyou + 1, 13).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub ●計記入sb() '大小
Sheets("合計").Select
gyou = ActiveCell.Row
Cells(gyou, 167) = Cells(2, 166)
retu = Cells(gyou, 167)
If retu = "" Or retu > 16 Then End
Cells(gyou, 167 + retu) = "●"
Cells(gyou + 1, 168).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Box_Kensaku()
' kensaku Macro
' マクロ記録日 : 2007/10/9
 
Range("B3:W64").Select
bango = Application.InputBox("番号入力して下さい")
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_kensaku_2()
' kensaku Macro
' マクロ記録日 : 2007/10/9
 
 Range("aB9:bc800").Select
bango = Application.InputBox("番号入力して下さい")
 Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_kensaku_3()

 Range("Bh9:bh800").Select
bango = Application.InputBox("番号入力して下さい")
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 桁分析()
Call saikeisanoff

Sheets("千百分析").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("千十分析").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("G5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("千一分析 ").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("K5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("百十分析").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("O5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("百一分析 ").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("S5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("十一分析 ").Select
Range("B5:C104").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("W5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("z3") = "=COUNT(奇遇!B4:B5000)"
Range("z3") = Range("z3") & "回"
Call saikeisanon
Range("B2").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub coooopio()

  Range("B5:C104").Select
Selection.Copy
Sheets("桁分析").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Sub seiti_keisan()
Dim tds_p、ds_p As String
Dim ds_pn As Integer
retu = 3
gyou = ActiveCell.Row
If Cells(gyou, retu) <> "" Then End
Range("C3:J3").Select
Application.CutCopyMode = False
Selection.Copy
Range(Cells(gyou, retu), Cells(gyou, retu)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("Q3:X3").Select
Application.CutCopyMode = False
Selection.Copy
Range(Cells(gyou, retu + 14), Cells(gyou, retu + 14)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(gyou, 12) = Application.Min(Range(Cells(gyou, 3), Cells(gyou, 8)))
Cells(gyou, 13) = Application.Max(Range(Cells(gyou, 3), Cells(gyou, 8)))
For x = 3 To 8
If Cells(gyou, x) <= 100 Then
ds_p = "●": ds_pn = ds_pn + 1
Else
ds_p = "○"
End If
tds_p = tds_p + ds_p
Next x
Cells(gyou, 15) = tds_p
Cells(gyou, 16) = ds_pn
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力へ()
w = 2: h = 2
actsheet = ActiveSheet.Name
If actsheet = "合計" Then
retu = 41
ElseIf actsheet = "奇遇" Then
retu = 21
End If
jp = Cells(1, retu) + 3 + h
Cells(jp, w).Select
End Sub
Sub kigu_tyusyutu()
Dim kai, i, ii, r, t, span, owari As Integer
Sheets("奇遇").Select
Range("bm5:cc3737").ClearContents
Cells(4, 65) = Empty
kai = Application.InputBox("集計間隔を入力して下さい", Default:=16)
owari = Cells(1, 21) + kai
Cells(4, 65) = kai
Call saikeisanoff '再計算を止めて計算を速くする・
For t = 0 To 15
i = 5
For ii = 0 To owari Step kai
  Cells(i, t + 66) = Application.Count(Range(Cells(5 + ii, t + 29), Cells(ii + kai + 4, t + 29)))
 If ii > 0 Then Cells(i - 1, 65) = ii
i = i + 1
Next ii
   Next t
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                     
Sub gokei_tyusyutu()
Dim kai, i, ii, r, t, span, owari As Integer
Sheets("合計").Select
Range("dt4") = Empty
Range("dt5:fe3737").ClearContents                                                      
Call saikeisanoff '再計算を止めて計算を速くする                                                        
kai = Application.InputBox("集計間隔を入力して下さい", Default:=15)
owari = Cells(1, 1) + kai
Cells(4, 124) = kai                                                               
For t = 0 To 36
i = 5
For ii = 0 To owari Step kai                                                     
Cells(i, t + 125) = Application.Count(Range(Cells(5 + ii, t + 45), Cells(ii + kai + 4, t + 45)))       If ii > 0 Then Cells(i - 1, 124) = ii
i = i + 1
Next ii
Next t
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                                                                 
Sub daisyo_tyusyutu()
Dim kai, i, ii, r, t, span, owari As Integer
Sheets("合計").Select
Range("hp4") = Empty
Range("hp5:if3737").ClearContents                                                                                                   Call saikeisanoff '再計算を止めて計算を速くする
    kai = Application.InputBox("集計間隔を入力して下さい", Default:=16)
 owari = Cells(1, 1) + kai
Cells(4, 224) = kai
 For t = 0 To 15
i = 5
For ii = 0 To owari Step kai                                                                                                       
Cells(i, t + 225) = Application.Count(Range(Cells(5 + ii, t + 186), Cells(ii + kai + 4, t + 186)))                                                                                                        
If ii > 0 Then Cells(i - 1, 224) = ii
i = i + 1
Next ii                                                                                                                    
Next t
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                                           
Sub 奇偶間隔式()
Call saikeisanon
Range("ac6") = "=IF(AND(ISNUMBER(D5),ISTEXT(D6)),D5,IF(AND(ISTEXT(D5),ISTEXT(D6)),0,IF(AND(ISTEXT(D5),ISTEXT(D6),ISNUMBER(D7)),1,"")))"
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub daisyou_ptn_kankaku() '●を大小に表示する
Dim k_iti As Integer
Sheets("合計").Select
Call saikeisanoff '再計算を止めて計算を速くする
i = 0
Do Until Cells(5 + i, 167) = ""
k_iti = Cells(5 + i, 167)
If k_iti < 1 And k_iti > 16 Then End
Cells(5 + i, 167 + k_iti) = "●"
i = i + 1
If i = 5000 Then Exit Do
Loop
Call saikeisanon
End Sub


Sub kiguu_ptn_kankaku() '●を奇遇に表示する
Dim k_iti As Integer
Sheets("奇遇").Select
Call saikeisanoff '再計算を止めて計算を速くする
i = 0
Do Until Cells(5 + i, 2) = ""
k_iti = Cells(5 + i, 2)
If k_iti < 1 And k_iti > 16 Then End
Cells(5 + i, 3 + k_iti) = "●"
i = i + 1
If i = 5000 Then Exit Do
Loop
Call saikeisanon
End Sub