ムラゴン ホーム
'ナンバーズ4のストレート分析
Dim hit_m(4000, 4) As String
Dim hitx(4000, 4) As long
Dim hit(4000, 4) As long
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub saikeisanoff()'再計算オフと画面変更オフ
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = False '画面変更をしない。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub saikeisanon()'再計算オンと画面変更オン
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = True
Application.ScreenUpdating = True '画面変更
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
変数 知らなかった本当の使い方
Dim hitx(6000, 4), i, j, k, l, m, n, t As Integer は
Dim hitx(6000, 4) As Long, i As Long, j As Long, k As Long
Dim l As Long, m As Long, n As Long, t As Long
'40パターン
Sub patapata_40() '当選数字ストレートパターン貼付け
Dim hitx(6000, 4) As long, l As long, m As long, n As long, t As long
Dim i As long, j As long, k As long
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
saikeisanoff
Erase hitx: i = 0: j = 0
i = 4
Do Until Cells(i, 3) = ""
For j = 1 To 4
Select Case j
Case 1: span = 1
Case 2: span = 11
Case 3: span = 21
Case 4: span = 31
End Select
hitx(i - 3, j) = Cells(i, j + 3) + span
Next j
i = i + 1
k = i
If i = 5000 Then Exit Do
Loop
m = 0: l = 0
For l = 1 To k - 4
For m = 1 To 4
Cells(l + 3, 15 + hitx(l, m)) = "●"
Next m
If l >= 2 Then
For n = 1 To 40
If Cells(l + 2, 15 + n) <> "●" And Cells(l + 3, 15 + n) = "●" Then
t = t + Cells(l + 2, 15 + n)
Cells(3 + l, 56) = t
Cells(3 + l, 57) = t / 4
End If
Next n
t = 0
End If
Next l
saikeisanon
Call 入力
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub cunters()
'飛び期間を記入する
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Worksheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
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 plascunt()
Dim p_0 As Integer
retu = ActiveCell.Column
gyou = ActiveCell.Row
p_0 = Cells(gyou, retu)
Cells(gyou + 1, retu) = p_0 + 1
End Sub
---------------------------------------------------
Sub 横詰め並べ()
retu = ActiveCell.Column
gyou = ActiveCell.Row
kijyun = Cells(1, 1)
gejyun = Cells(gyou, 1)
Range(Cells(gyou, 3), Cells(gyou, gejyun + 2)).Select
Selection.Cut
Cells(gyou, kijyun - gejyun + 2).Select
ActiveSheet.Paste
Cells(gyou + 1, 3).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去()
'飛び期間の空行を詰めて表示する。
retu = ActiveCell.Column
gyou = ActiveCell.Row
Dim x, i, k As Integer
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
Range("BJ6:CW6").Select
Selection.Copy
Range("BJ7:CW4500").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("db4:eo800").ClearContents
saikeisanoff
For x = 1 To 40
i = 0: k = 0
Do Until Cells(4 + i, 3) = ""
If Cells(4 + i, 61 + x) <> "" Then
Cells(4 + i - k, 105 + x).Value = Cells(4 + i, 61 + 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
Cells(gyou, retu).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去_2()
'飛び期間の空行を詰めて表示する。
Dim x As long, i As long, k As long
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
Range("db4:eo5000").ClearContents
saikeisanoff
For x = 1 To 40
i = 0: k = 0
Do Until Cells(4 + i, 3) = ""
If Cells(4 + i, 15 + x) = "●" Then
If i = 0 Then
Cells(4 + i - k, 105 + x).Value = 0
ElseIf i > 0 Then
If Cells(3 + i, 15 + x) <> "●" Then
Cells(4 + i - k, 105 + x).Value = Cells(3 + i, 15 + x).Value
Else
Cells(4 + i - k, 105 + x).Value = 0
End If
End If
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 空白除去()
retu = ActiveCell.Column
gyou = ActiveCell.Row
t_w = 44
i = 0: k = 0
Do Until Cells(gyou + i, 1) = ""
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 飛び記入()
'記入する行をクリックした後マクロ実行する。
gyou = ActiveCell.Row
Call saikeisanoff
If gyou <= 3 Or Cells(gyou, 16) <> "" Then End
For i = 1 To 40
If Cells(gyou - 1, 15 + i) = "●" Then
Cells(gyou, 15 + i) = 1
Else
Cells(gyou, 15 + i) = Cells(gyou - 1, 15 + i) + 1
End If
Next i
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 飛び記入_4() '記入する行をクリックした後マクロ実行する。
retu = ActiveCell.Column
gyou = ActiveCell.Row
For i = 1 To 40
If Cells(gyou - 1, 15 + i) = "●" Then '前回●なら今回1、でなければ+1する。
If Cells(gyou, 15 + i) = "" Then Cells(gyou, 15 + i) = 1
Else
If Cells(gyou, 15 + i) = "" Then Cells(gyou, 15 + i) = Cells(gyou - 1, 15 + i) + 1
End If
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 休み期間() '行をクリックした後マクロ実行する。
gyou = ActiveCell.Row
Range(Cells(gyou, 16), Cells(gyou, 55)).Select
Selection.Copy
Sheets("飛び計").Select
Range("P2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("P12:P41").Select
Application.CutCopyMode = False
Selection.Cut
Range("Q2").Select
ActiveSheet.Paste
Range("Q12:Q31").Select
Selection.Cut
Range("R2").Select
ActiveSheet.Paste
Range("R12:R21").Select
Selection.Cut
Range("S2").Select
ActiveSheet.Paste
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
Range("M2").Select
Selection.Copy
Sheets("飛び計").Select
Range("T1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 多重当選カウント()
retu = ActiveCell.Column
gyou = ActiveCell.Row
t_w = 44
i = 0: k = 0
Do Until Cells(gyou + i, retu) = ""
If Cells(gyou + i, retu) = "●" Then
k = k + 1
kk = k
Else
Cells(gyou + i + k - 1, retu + 2) = Empty
Cells(gyou + i, retu + 2) = kk
k = 0
End If
If i = 4001 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "ﾃﾞｰﾀ等をﾁｪｯｸして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub tajyuu()
Sheets("多重当選").Select
Range("P51:BC56").Select
Selection.Copy
Range("S4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
Sub rencunters()
retu = ActiveCell.Column
gyou = ActiveCell.Row
Call saikeisanoff
i = 0
Do Until Cells(gyou + i, retu) = ""
If Cells(gyou + i, retu) <> 0 Then
Cells(gyou + i, retu + 1) = k + 1
k = k + 1
If Cells(gyou + i + 1, retu) = 0 Then
rentyan = k: k = 0
Cells(gyou + i - 1, retu + 2) = rentyan
End If
End If
If i = 4001 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "ﾃﾞｰﾀ等をﾁｪｯｸして下さい。": End
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ido_inp()
Dim atai As long
Sheets("多重当選").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
If gyou < 55 Or gyou > 70 Then End
atai = Cells(61, retu)
If atai = 0 Then End
i = 0
Do Until Cells(gyou + i, retu) = ""
Cells(gyou + i + 1, retu).Select
If i = 4001 Then Exit Do
i = i + 1
Loop
start = MsgBox("okしますか？", vbYesNo)
If start = vbYes Then '値記入する
Cells(gyou + i, retu) = atai * -1
Cells(gyou, retu).Select
Else
Cells(61, retu).Select
End If
End Sub
-----------------------------------------------
Sub 多重整列()
start = MsgBox("整列開始しますか？", vbYesNo)
Dim maxdara As long, i As long, motosuu As long
If start = vbNo Then End
Sheets("多重当選").Select
Range("P64:BC506").Select
Selection.Copy
Range("BJ64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
maxdata = Cells(65, 1)
For i = 62 To 101
motosuu = Cells(64, i)
Range(Cells(66, i), Cells(66 + motosuu, i)).Select '番号
Selection.Cut
Cells(66 + maxdata - motosuu, i).Select
ActiveSheet.Paste
Next i
Cells(66 + maxdata, 81).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 回go()
ActiveWindow.LargeScroll Down:=3
ActiveWindow.SmallScroll Down:=17
Range("O104").Select
End Sub
Sub kanngo()
ActiveWindow.ScrollRow = 236
ActiveWindow.SmallScroll Down:=42
Range("O289").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Public patan As long
Dim bango As String
--------------------------------------------
Sub testbagen()
For i = 1 To 3000
Range(Cells(i, 1), Cells(i, 1)).Select
If Cells(i, 1) = "" Then Exit For
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(i, 1) = "●"
i = i + 1
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta4() 'ストレート順での3桁出現回号表示(全4000データ)
three_keta千百十 'サブプログラム three_keta千百十
three_keta千百一 'サブプログラム three_keta千百一
three_keta千十一
three_keta百十一
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百十() 'ストレート順での3桁出現回号表示
Dim i, bangoend As Integer
Sheets("三桁分析").Select
Range("j28:alu62").Clear
bangoend = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(2, 15)
saikeisanoff
setretu = 0
i = 4
Do Until Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3) = ""
setretu = Val(Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 4) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ"). _
Cells(i, 5) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 6))
caunter = Application.Count(Range(Cells(28, 10 + setretu), Cells(45, 10 + setretu)))
Cells(28 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1)
Cells(47 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3)
Cells(26, 10 + setretu) = caunter + 1
If Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1) = bangoend Then
saikeisanon
Cells(27, 10 + setretu).Select
End If
i = i + 1
If i = bangoend + 50 Then Exit Do
Loop
Cells(14, 1) = Cells(24, ActiveCell.Column)
Cells(15, 1) = Cells(17, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百一() 'ストレート順での3桁出現回号表示
Dim i As long, bangoend As long
Sheets("三桁分析").Select
Range("j64:alu99").Clear
bangoend = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(2, 15)
saikeisanoff
setretu = 0
i = 4
Do Until Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3) = ""
setretu = Val(Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 4) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ"). _
Cells(i, 5) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 7))
caunter = Application.Count(Range(Cells(64, 10 + setretu), Cells(81, 10 + setretu)))
Cells(64 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1)
Cells(83 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3)
Cells(63, 10 + setretu) = caunter + 1
If Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1) = bangoend Then
saikeisanon
Cells(27, 10 + setretu).Select
End If
i = i + 1
If i = bangoend + 50 Then Exit Do
Loop
Cells(16, 1) = Cells(24, ActiveCell.Column)
Cells(17, 1) = Cells(18, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Sheets("三桁分析").Select
Range("j101:alu136").Clear
bangoend = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(2, 15)
setretu = 0
i = 4
Do Until Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3) = ""
setretu = Val(Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 4) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ"). _
Cells(i, 6) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 7))
caunter = Application.Count(Range(Cells(101, 10 + setretu), Cells(119, 10 + setretu)))
Cells(101 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1)
Cells(120 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3)
Cells(100, 10 + setretu) = caunter + 1
If Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1) = bangoend Then
saikeisanon
Cells(27, 10 + setretu).Select
End If
i = i + 1
If i = bangoend + 50 Then Exit Do
Loop
Cells(18, 1) = Cells(24, ActiveCell.Column)
Cells(19, 1) = Cells(19, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta百十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Sheets("三桁分析").Select
Range("j138:alu173").Clear
bangoend = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(2, 15)
setretu = 0
i = 4
Do Until Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3) = ""
setretu = Val(Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 5) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ"). _
Cells(i, 6) & Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 7))
Cells(20, 1) = Cells(i, 5)
caunter = Application.Count(Range(Cells(138, 10 + setretu), Cells(156, 10 + setretu)))
Cells(138 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1)
Cells(157 + caunter, 10 + setretu) = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 3)
Cells(137, 10 + setretu) = caunter + 1
If Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(i, 1) = bangoend Then
saikeisanon
Cells(27, 10 + setretu).Select
End If
i = i + 1
If i = bangoend + 50 Then Exit Do
Loop
Cells(20, 1) = Cells(24, ActiveCell.Column)
Cells(21, 1) = Cells(20, ActiveCell.Column)
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box_kensaku()
UserForm2.Show 'ﾕｰｻﾞｰﾎｰﾑを開く
Sheets("三桁分析").Select
On Error GoTo errorcheck
Range("j24:alu24").Select
bango = Application.InputBox("3桁番号入力して下さい")
If bango = "" Then End
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
Cells(10, 1) = patan
Cells(gyou + patan, retu).Select
Exit Sub
errorcheck:
MsgBox ("番号がありません。チェックして下さい"): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub st番号1110表示() 'ストレート番号表示する。
saikeisanoff
Worksheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Range("C4:C4000").Copy
Sheets("三桁分析").Select
Range("ALW28").Select
ActiveSheet.Paste
For j = 1 To 1000
i = 1
Do Until Cells(27 + i, 9 + j) = ""
If Cells(27 + i, 9 + j) <> "" Then
bango = Cells(27 + i, 9 + j)
Cells(27 + i, 9 + j) = Cells(27 + bango, 1011)
End If
i = i + 1
If i = 15 Then Exit Do
Loop
Next j
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub three_keta千百十一() 'ストレート順での3桁出現回号表示
saikeisanoff
Range("j28:alu42").Clear
bangoend = Application.CountA(Range("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!$C$4:$C$4000"))
setretu = 0
i = 28
Do Until Cells(i, 1) = bangoend + 1
For j = 2 To 5
setretu = Cells(i, j).Value
Select Case j 'データ表示列位置の設定
Case 2
span = 28
Case 3
span = 46
Case 4
span = 64
Case 5
span = 90
End Select
caunter = Application.Count(Range(Cells(28, 10 + setretu), Cells(42, 10 + setretu)))
Cells(28 + caunter, 10 + setretu) = Cells(i, 1)
Cells(26, 10 + setretu) = caunter + 1
Next j
i = i + 1
If Cells(i, 1) = bangoend + 1 Then Cells(27, 10 + setretu).Select
If i = 4000 Then Exit Do
Loop
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub next4number() '次数字を表示する
On Error GoTo errorcheck
Call saikeisanoff '再計算を止めて計算を速くする・
Dim nenum(4) As String, stopnum As Integer
Call saikeisanon
bangoend = Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Cells(2, 15)
Range("b12") = "=ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D4&ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D5"
Range("c12") = "=ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!E4&ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!E5"
Range("d12") = "=ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!F4&ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!F5"
Range("e12") = "=ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!G4&ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!G5"
Range("ｆ12") = "=SMALL(ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D4:G4,1)&SMALL(ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D4:G4,2)&SMALL(ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D4:G4,3)&SMALL(ｽﾄﾚｰﾄﾊﾟﾀｰﾝ!D4:G4,4)"
Range("b12:f12").Copy Range(Cells(13, 2), Cells(bangoend + 11, 6))
Range(Cells(13, 2), Cells(bangoend + 11, 6)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
kaigo = Application.InputBox("開始回号番号入力して下さい")
If kaigo <= 0 Then End
kaigo = kaigo + 10
Range(Cells(kaigo, 7), Cells(kaigo + 4000, 106)).Select
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
stopnum = Cells(10, 1) + 1
i = kaigo '12
Call saikeisanoff
Do Until Cells(i, 1) = Cells(10, 1) + 1
For n = 1 To 4 '百十一に分ける。
setretu = Cells(i, 1 + n).Value '番号によりデータ記入位置を設定する。
Cells(i, setretu + 7) = Cells(i, 1 + n)
nenum(n) = Cells(i, 1 + n)
If n = 1 Then
Cells(i, setretu + 7).Select
With Selection.Font
.Color = -16776961
Selection.Font.Bold = True
End With
ElseIf n = 2 Then
Cells(i, setretu + 7).Select
With Selection.Font
.Color = -11489280
End With
If nenum(n - 1) = nenum(n) Then
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
Selection.Font.Underline = xlUnderlineStyleDouble
End With
End If
ElseIf n = 3 Then
Cells(i, setretu + 7).Select
With Selection.Font
.ThemeColor = xlThemeColorAccent6
Selection.Font.Underline = xlUnderlineStyleDouble
End With
If nenum(n - 1) = nenum(n) Or nenum(n - 2) = nenum(n) Then
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
Selection.Font.Underline = xlUnderlineStyleDouble
End With
End If
Else
Cells(i, setretu + 7).Select
With Selection.Font
.Color = 2
Selection.Font.Underline = xlUnderlineStyleSingle
End With
If nenum(n - 3) = nenum(n) Or nenum(n - 2) = nenum(n) Or nenum(n - 1) = nenum(n) Then
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 10092543
End With
End If
End If
Next n
i = i + 1
If i = stopnum + 10 Then Exit Do
Loop
Call saikeisanon '再計算をオンにする
Exit Sub
errorcheck:
MsgBox ("ありません。チェックして下さい"): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub kankaku_cunters()
retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
For i = 1 To 777
If Cells(gyou + i, retu) = "" Then
j = j + 1
Else
Exit For
End If
Next i
MsgBox "間隔は " & (j)
If i = 999 Then End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力()
jp = Cells(2, 15)
Cells(jp + 4, 3).Select
End Sub
Sub 入力赤丸()
Dim maruiti As Object
Sheets("ｽﾄﾚｰﾄﾊﾟﾀｰﾝ").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
Cells(gyou + 1, retu).Select
j = 1
If Cells(gyou + j, retu) <> "●" Then
Do Until Cells(gyou + j, retu) = "●"
If j > 3 Then Exit Do
j = j + 1
Loop
End If
Cells(gyou + j, retu).Select
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.Color = -16776961
End Sub
