趣味のエクセルマクロ

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

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