Sub box_kensaku() ’ナンバーズ4のボックス出現回数集計
Dim bango As String
  On Error GoTo errorcheck
Sheets("box").Select
Range("B3:W65").Select
bango = Application.InputBox("box番号入力して下さい", Default:=Cells(1, 25))
Cells(1, 25) = bango
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 + 1), Cells(gyou, retu + 1)).Select
  res = MsgBox("集計しますか", vbYesNo)
If res = vbYes Then
Cells(gyou, retu + 1) = Cells(gyou, retu + 1) + 1’回数+1する。
End If
  box_kensaku_3　’サブルーチンに行く
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
    'MsgBox "エラー番号" & Err & ":" & Error(Err): End
End Sub

ナンバーズ4ボックス出現回数；5186回

当選番号を小さい順に並べて手動でボックス番号にしているが？最初から当選番号を入力してマクロでボックス番号に変換したのが良い。当選番号は4桁の数字（ここでは文字としてる）だが、違った桁数や文字を受け付けない様にしたのが良いでしょうね。
もっとも、Range("B3:W65").Selectで指定した範囲に番号が無い場合受け付けないので問題は無いかも知れませんが？
----------------------------------------------------------------------------------
Sub box_kensaku_3()’前回のボックス番号を Default(規定値)として
Dim bango As String
   Sheets("box").Select
On Error GoTo errorcheck
Range("Bh9:bh800").Select
bango = Application.InputBox("box番号入力して下さい", Default:=Cells(1, 25))
Cells(2, 25) = bango
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 + 1), Cells(gyou, retu + 1)).Select
  res = MsgBox("集計しますか", vbYesNo)
If res = vbYes Then
  Cells(gyou, retu + 1) = Cells(gyou, retu + 1) + 1
End If
 Call boxsort
  Range("B3:W64").Select
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub plas_1() 'ﾎﾞｯｸｽ間隔計算  789555
Sheets("boxリスト").Select
  On Error GoTo errorcheck
boxx = InputBox("今回のbox は?", Default:=Sheets("box").Cells(1, 25))
Selection.AutoFilter Field:=26, Criteria1:=boxx, Operator:=xlAnd
 Cells(1, 32) = Cells(1, 32) + 1 '次回表示
Columns("AE:AE").Select
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
           'MsgBox "エラー番号" & Err & ":" & Error(Err): End
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub stBoxx_Kensaku()　’ストレート番号を追加する準備
On Error GoTo errorcheck
   'Static maeban
maeban = Cells(1, 1)
Range("B2:b1430").Select
boxx = InputBox("今回のbox は?", Default:=Sheets("box").Cells(1, 25))
maeban = boxx
Cells(1435, 1) = maeban
Selection.Find(What:=boxx, 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 As long, gyou As long, retu As long, Start As long, kai As long, k As long
      Dim st_no As String
     
    saikeisanoff

        Sheets("要素かけ算").Select
              st_no = Cells(2, Cells(1, 149) + 153)
                
         Sheets("boxストレート").Select
       gyou = ActiveCell.Row
           retu = ActiveCell.Column
         
          Start = MsgBox(st_no & "で入力しますか？", vbYesNo)
 
          If Start = vbNo Then End
  
           If Cells(gyou, retu) = "" Then Cells(gyou, retu) = st_no
          
           kai = Application.CountIf(Range(Cells(gyou, 3), Cells(gyou, retu)), st_no)
          
           k = 1
           If kai >= 2 Then
                       Cells(gyou, retu).Select
             Selection.Font.Bold = True
                          
              Do Until Cells(gyou, retu - k) = st_no
          
               k = k + 1
              If retu - k = 2 Then Exit Do
              Loop
               If k >= 1 And Cells(gyou, retu - k) = st_no Then
                Cells(gyou, retu - k).Select
             
               Selection.Font.Bold = True
              End If
        
           End If
      
      saikeisanon
             Cells(gyou + 1, retu).Select
   End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub yosoutennkai()
'当たる博士予測展開
' マクロ記録日 : 2007/3/2  "C:\Users\mk\Desktop\数字選択DTSK"
Sheets("boxリスト").Select
Range("AN10").Select
　 ChDir "C:\Users\mk\Desktop\数字選択DTSK"
f_name = Application.InputBox("ファイル名？数字のみ例213501")
f_name = "rn4" & f_name & ".txt"
Cells(2, 111) = f_name
　namer = "C:\Users\mk\Desktop\数字選択DTSK\" & f_name
Workbooks.OpenText Filename:= _
   namer, Origin:=932, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(4, _
1), Array(5, 2), Array(9, 2), Array(10, 2), Array(14, 2), Array(15, 2), Array(19, 2), Array( _
20, 2), Array(24, 2), Array(25, 2), Array(29, 2), Array(30, 2), Array(34, 2), Array(35, 2), _
Array(39, 2), Array(40, 2), Array(44, 2), Array(45, 2), Array(49, 2), Array(50, 2), Array( _
54, 2), Array(55, 2), Array(59, 2), Array(60, 2), Array(64, 2), Array(65, 2), Array(69, 2), _
Array(70, 2), Array(74, 2), Array(75, 2), Array(79, 1)), TrailingMinusNumbers:=True
Rows("51:80").Select
Selection.Copy
Range("C90").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub hakase_tenkai()
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
  FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(5, 1), Array(9, 1), Array(10, 1), _
Array(14, 1), Array(15, 1), Array(19, 1), Array(20, 1), Array(24, 1), Array(25, 1), Array( _
29, 1), Array(30, 1), Array(34, 1), Array(35, 1), Array(39, 1), Array(40, 1), Array(44, 1), _
Array(45, 1), Array(49, 1), Array(50, 1), Array(54, 1), Array(55, 1), Array(59, 1), Array( _
60, 1), Array(64, 1), Array(65, 1), Array(69, 1), Array(70, 1), Array(74, 1), Array(75, 1), _
Array(79, 1)), TrailingMinusNumbers:=True
Rows("51:60").Select
Selection.Copy
Range("K66").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=10
Application.CutCopyMode = False
Selection.ClearContents
Selection.ClearContents
Rows("51:60").Select
Selection.Copy
Range("J66").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
      Application.CutCopyMode = False
ActiveWorkbook.Worksheets("当たる展開").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("当たる展開").Sort.SortFields.Add Key:=Range("J66"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("当たる展開").Sort
.SetRange Range("J66:S16449")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 飛びコピー()
Windows("NO.4ST分析.xlsm").Activate
Sheets("飛び計").Select
Range("I2:I10001").Select
Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Range("Ad2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Ac2").Select
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub kesu()
Range("A2:A716").Select
Selection.ClearContents
Range("Al2:Am716").Select
Selection.ClearContents
Range("AJ2").Select
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub tbcopy()
Sheets("box飛").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
Range(Cells(gyou, 16), Cells(gyou, 25)).Select
Selection.Copy
Range("P2").Select '飛び計算元コピー
ActiveSheet.Paste
Range("P3:Y3").Select
Selection.Copy '色を消す
Range(Cells(gyou + 1, 16), Cells(gyou + 1, 25)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
For i = 1 To 10
If Cells(gyou, 15 + i) = "●" Or Cells(gyou, 15 + i) = "◎" Then
  If Cells(gyou + 1, 15 + i) <> "●" And Cells(gyou + 1, 15 + i) <> "◎" Then
    Cells(gyou + 1, 15 + i) = 1
End If
End If
Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub tbcopy_kai()　’飛び間隔と赤丸集計
Dim t As long, akamarukazu As long
Dim akamaruiti As Object
Sheets("box飛").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
 'スライドコピーする。
Range(Cells(gyou - 1, 16), Cells(gyou, 25)).Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range(Cells(gyou - 1, 16), Cells(gyou + 1, 25)), Type:=xlFillDefault
Range(Cells(gyou - 1, 16), Cells(gyou + 1, 25)).Select
    Range(Cells(gyou, 16), Cells(gyou, 25)).Select
Selection.Copy
Range("P2").Select '飛び計算元コピー
ActiveSheet.Paste
Range("P3:Y3").Select
Selection.Copy '色を消す
Range(Cells(gyou + 1, 16), Cells(gyou + 1, 25)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
For i = 1 To 10
If Cells(gyou, 15 + i) = "●" Or Cells(gyou, 15 + i) = "◎" Then
     If Cells(gyou + 1, 15 + i) <> "●" And Cells(gyou + 1, 15 + i) <> "◎" Then
        Cells(gyou + 1, 15 + i) = 1
    End If     
End If
Next i
t = 0
For j = 1 To 10 '飛び合計計算
If Cells(gyou, 15 + j) = "●" And Val(Cells(gyou - 1, 15 + j)) >= 1 Then
　 t = t + Cells(gyou - 1, 15 + j)
ElseIf Cells(gyou, 15 + j) = "◎" And Val(Cells(gyou - 1, 15 + j)) >= 1 Then
  　t = t + Cells(gyou - 1, 15 + j) * 2
End If
Next j
  Cells(gyou, 26) = t
  akamarukazu = 0
For k = 16 To 25
   Set akamaruiti = Application.Cells(gyou, k)
If akamaruiti.Font.Color = 255 Then akamarukazu = akamarukazu + 1
Next k
  Cells(gyou, 27) = akamarukazu
  Range("O4:AA4").Select
 Selection.Delete Shift:=xlUp
 Cells(gyou - 1, 16).Select
End Sub
 －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub tbcopy2()
Sheets("box飛").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
Range(Cells(gyou, 16), Cells(gyou, 25)).Select
Selection.Copy
Range("P2").Select
ActiveSheet.Paste
Range("P3:Y3").Select
Selection.Copy
Range(Cells(gyou + 1, 16), Cells(gyou + 1, 25)).Select
　Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
For i = 1 To 10
If Cells(gyou, 15 + i) = "●" Or Cells(gyou, 15 + i) = "◎" Then
If Cells(gyou + 1, 15 + i) <> "●" And Cells(gyou + 1, 15 + i) <> "◎" Then
   Cells(gyou + 1, 15 + i) = 1
End If     
End If
Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub box_tyuusyutu()
Selection.AutoFilter Field:=29, Criteria1:="<>#N/A", Operator:=xlAnd
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub st_tyuusyutu()
Selection.AutoFilter Field:=33, Criteria1:="<>#N/A", Operator:=xlAnd
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 桁6copy()
Dim keta_1(100, 6) As long
Dim keta_2(10000, 6) As long
saikeisanoff
　Windows("ｎｏ4各種分析.xls").Activate
Sheets("桁分析").Select
Range("C5").Select
For h = 1 To 6
For i = 1 To 100
  keta_1(i, h) = Cells(4 + i, h * 4 - 1)
Next i
Next h
　Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xls").Activate
   Sheets("万リスト").Select
For h = 1 To 6
For i = 1 To 100
　　Cells(1 + i, 36 + h) = keta_1(i, h) 
　Next i
Next h
saikeisanon
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub s_kesi()
Range("Ap2:BX777").Select
Selection.Delete Shift:=xlToLeft
Range("Ao2").Select
End Sub
-------------------------------------------------------
Sub box_kensaku()
Dim bango As String
  On Error GoTo errorcheck
Sheets("box").Select
Range("B3:W64").Select
bango = Application.InputBox("box番号入力して下さい", Default:=Cells(1, 25))
Cells(1, 25) = bango
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 + 1), Cells(gyou, retu + 1)).Select
      res = MsgBox("集計しますか", vbYesNo)
If res = vbYes Then
  Cells(gyou, retu + 1) = Cells(gyou, retu + 1) + 1
End If
  box_kensaku_3
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
      'MsgBox "エラー番号" & Err & ":" & Error(Err): End
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub box_kensaku_2()

Range("aB9:bc800").Select
bango = Application.InputBox("box番号入力して下さい")
    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()
 Dim bango As String
Sheets("box").Select
On Error GoTo errorcheck
Range("Bh9:bh800").Select
bango = Application.InputBox("box番号入力して下さい", Default:=Cells(1, 25))
Cells(2, 25) = bango
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 + 1), Cells(gyou, retu + 1)).Select
       res = MsgBox("集計しますか", vbYesNo)
If res = vbYes Then
  Cells(gyou, retu + 1) = Cells(gyou, retu + 1) + 1
End If
　Call boxsort
Range("B3:W64").Select
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 回号連動()
Dim ban_go As long
 ban_go = Application.InputBox("番号入力して下さい", 1)
　If ban_go > 9 And ban_go < 0 Then End
For i = 2 To 716
  For n = 1 To 4
    If ban_go = Cells(i, n + 2) Then
　     Cells(i, 1) = Cells(i, 1) & "*"
　     Exit For
　  End If
   Next n
Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 三桁連動()
Dim sanban_go As String
 sanban_go = Application.InputBox("三桁BOX番号入力して下さい", 1)
' If ban_go > 9 And ban_go < 0 Then End
For i = 2 To 716
For n = 1 To 4
  If ban_go = Cells(i, n + 2) Then
    Cells(i, 1) = Cells(i, 1) & "*"
    Exit For
  End If
 Next n
Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 欠け算差抽出()
Dim kban_go As long
 kban_go = Application.InputBox("欠け算差番号入力して下さい", 1)
 If kban_go >= 6 Then End
　 For i = 2 To 716
　　  For n = 1 To 4
　　    If kban_go = Cells(i, n + 33) Then
　      　Cells(i, 38) = Cells(i, 38) & kban_go
　　  End If
        Next n
  Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub kakezan_kensaku()
Dim bango As String
  Sheets("boxかけ算").Select
Range("B2:W715").Select
bango = Application.InputBox("かけ算番号入力して下さい")
For i = 1 To 715
   For j = 1 To 10
         If Cells(i + 1, j + 11) = bango Then
          Cells(i + 1, 1) = bango
        End If
Next j
Next i
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

ナンバーズ4 の かけ算展開(2桁) 
Sub kake2ketanlis()
saikeisanoff
i = 154
Do Until Cells(3, i) = ""
boxbango = Cells(3, i)
  Range("Z4:Z718").Select '検索する
Selection.Find(What:=boxbango, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
  gyou = ActiveCell.Row
Range(Cells(gyou, 27), Cells(gyou, 44)).Copy
Cells(4, i).Select
  Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
　If i > 5000 Then Exit Do
  i = i + 1
Loop
saikeisanon
End Sub

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub kake2ketanlis_1()
   saikeisanoff
Dim retu As long
Dim boxbango As String
i = 154
retu = ActiveCell.Column
 Cells(3, retu) = Cells(1, 1)
boxbango = Cells(3, retu)
If boxbango = "" Then End
 Range("Z4:Z718").Select '検索する
Selection.Find(What:=boxbango, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
gyou = ActiveCell.Row
Range(Cells(gyou, 27), Cells(gyou, 44)).Copy
Cells(4, retu).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
　saikeisanon
  End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub red_maru() '赤丸にする。
 With Selection.Font
.Color = 255
End With
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub 入力◎●()’当選番号のシングルとそれ以外を記入する
Dim t As long
 Sheets("box飛").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
 bango = Application.InputBox("番号入力して下さい●=1､◎=2", Default:=1)
   If bango = 1 Then
    　Cells(gyou, retu) = "●"
　ElseIf bango = 2 Then
　　Cells(gyou, retu) = "◎"
　Else
     End
   End If
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub filter()
For ff = 1 To 25
Selection.AutoFilter Field:=ff
Next ff
z = 1
Do Until Cells(1 + z, 1) = ""
  z = z + 1
Loop
Range("a２").Select
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub saikeisanon()’再計算をする
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
End Sub
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
Sub saikeisanoff()’再計算を止める
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub tatecopi() '横に並んだデータを縦に並べる　（当たる博士のデータを）
gyou = ActiveCell.Row
retu = ActiveCell.Column
Dim kouhosuu(600) As String
i = 0:  y = 0: z = 0
Do Until Cells(gyou, retu + i) = ""
　k = 0
 Do Until Cells(gyou + k, retu + i) = ""
    y = y + 1: z = y
  kouhosuu(y) = Cells(gyou + k, retu + i)
  Range(Cells(gyou + k, retu + i), Cells(gyou + k, retu + i)).Select
  Selection.ClearContents
   If k > 280 Then Exit Do
    k = k + 1
  Loop
 If i > 501 Then Exit Do
  i = i + 1
Loop
For y = 1 To z
  Range(Cells(gyou + y, retu), Cells(gyou + y, retu)).Select
        Selection.NumberFormatLocal = "@"
Cells(gyou + y, retu) = kouhosuu(y)
Next y
Range("av1") = z
Range(Cells(gyou, retu), Cells(gyou, retu)).Sort Key1:=Range(Cells(gyou, retu), Cells(gyou + k, retu + i)), Order1:=xlAscending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
, SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Cells(gyou + 1, retu).Select
End Sub
-----------------------------------------------
Sub 消す()
Sheets("boxかけ算").Select
Range("A2:A716").Select
Selection.ClearContents
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 間隔コピー()
 ChDir "C:\Users\km\Desktop\NUMBERS 関 連"
Workbooks.Open Filename:="C:\Users\km\Desktop\NUMBERS 関 連\n4プロパティ分析.xlsm"
 Windows("n4プロパティ分析.xlsm").Activate
Sheets("千百分析").Select
Range("K1:DF70").Select
Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("B3").Select
ActiveSheet.Paste
Windows("n4プロパティ分析.xlsm").Activate
Sheets("千十分析").Select
Range("K1:DF70").Select
Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("cz3").Select
ActiveSheet.Paste
Windows("n4プロパティ分析.xlsm").Activate
Sheets("千一分析 ").Select
Range("K1:DF70").Select
Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("gx3").Select
ActiveSheet.Paste
Windows("n4プロパティ分析.xlsm").Activate
Sheets("百十分析").Select
Range("K1:DF70").Select
Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("kv3").Select
ActiveSheet.Paste
Windows("n4プロパティ分析.xlsm").Activate
Sheets("百一分析 ").Select
Range("K1:DF70").Select
  Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("ot3").Select
ActiveSheet.Paste
   Windows("n4プロパティ分析.xlsm").Activate
Sheets("十一分析 ").Select
Range("K1:DF70").Select
  Selection.Copy
Windows("No.4予測ﾊﾟﾀｰﾝ抽出.xlsm").Activate
Sheets("間隔").Select
Range("sr3").Select
ActiveSheet.Paste
Columns("B:wm").Select
Selection.ColumnWidth = 4.63
End Sub
----------------------------------------------------------------------------------

Sub nmbers4()　'クイックピック用マクロ
saikeisanoff
Sheets("QP").Select
Randomize
Range("a1:b10").Select
Selection.ClearContents
　count_5 = 0
For i = 1 To 4
 　 kai = Int(Rnd() * 10)
　  Cells(i, 1) = kai
 　Range("c1") = "=count(a1:a10)"
Next i
　Range("A1:A4").Select
　Selection.Copy
　Range("G10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=True
　saikeisanon
End Sub

マクロ作成方法12（マクロ自動記録）
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 そ_と千一()　’千百から十一までの２桁毎の未出間隔並び替え
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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー

マクロ作成方法14（自動記録・検索）
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 As long, gyou As long, retu As long, Start As long, kai As long
      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

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 long
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 long
      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 As long, i As long, k As long, retu_1 As long, retu_2 As long
      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 As long, i As long, k As long, retu_1 As long, retu_2 As long
      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 long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
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)

 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 long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
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)

 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 As long, i As long, k As long
  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 long
Dim i As long, ii As long, j As long, jj As long, k, start As long
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 long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long, motosuu As long
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) <> ""

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