ムラゴン ホーム
3.No.3 分析
Sub kiguu3間隔() '奇数偶数の間隔でアンダーバー引く
Dim i As long, k As long, gyou As long, kiguu As long
Dim kiguubar As Range , 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 As long, k As long, gyou As long, retu As long, deme As long
Dim demebar As Range , 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 As long, k As long, gyou As long, total As long
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 As long, k As long, gyou As long, total As long, frg As long
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 As long, k As long, gyou As long, space As long, frg As long
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 As long, k As long, i As long, n As long, caunter As long, Maxx As long
Dim setretu As long, span As long, writretu As long
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 As long, k As long, i As long, n As long, nn As long, caunter As long, Maxx As long
Dim setretu As long, span As long, writretu As long
Dim kaigo As long, start As long, gyou As long
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 As long, k As long, x As long, n As long, nn As long, caunter As long
Dim Maxx As long,setretu As long, span As long
Dim jwritretu As long, kaigo As long, startgyou As long, start As long, gyou As long
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 long
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 As long, jisyyji As long, h As long, j As long, i As long
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 long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
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 long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
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 As long, i As long, ii As long, r As long, t As long, span As long, owari As long
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 As long, i As long, ii As long, r As long, t As long, span As long, owari As long
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 As long, retu As long, stretu As long, deme As long
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