1.miniloto
B~G列の当選番号データからj~AN列のパターン表をマクロで表示する。
ユーザーホーム(UserForm)
変数 知らなかった本当の使い方
Public pata_1 As String, pata_2 As String
Public pata_f As long
Dim hit(1000, 7) As long
Dim retu As long
Dim gyou As long
Dim colohani As long
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub patapata() '当選数字パターン貼付け
saikeisanoff
Erase hit: pata_1 = "": pata_2 = "": pata_f = 0
UserForm1.Show 'ユーザーホームを開く
Call syoukyo'syoukyoマクロを実行
actsheet = ActiveSheet.Name
If actsheet <> "リスト2" Then
Sheets("元データ").Select
Range("B2:I1002").Select
Selection.Copy
Sheets(actsheet).Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
i = 2
Do Until Cells(i, 2) = ""
For j = 1 To 6
hit(i - 1, j) = Cells(i, j + 1)
Next j
If i = 900 Then Exit Do
i = i + 1
k = i
Loop
For i = 1 To k - 2
For j = 1 To 6
If pata_f = 1 Then
If j = 6 Then
Cells(i + 1, 9 + hit(i, j)) = 0 '"○"
Else
Cells(i + 1, 9 + hit(i, j)) = hit(i, j)
End If
Else
If j = 6 Then pata = pata_1 Else pata = pata_2
If hit(i, j) > 0 Then
Cells(i + 1, 9 + hit(i, j)) = pata
End If
End If
Next j
Next i
With Selection.Borders(xlLeft)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlRight)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlTop)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlBottom)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Call renpata '連番数字 renpata マクロ実行
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
1と31も連番数字とする。ボーナス数字除く
Sub renpata() '連番数字
Columns("B:F").Select
Selection.Interior.ColorIndex = xlNone
i = 2
Do Until Cells(i, 2) = ""
For j = 5 To 2 Step -1
If hit(i - 1, j) - hit(i - 1, j - 1) = 1 Then
karaiti = Cells(i, j) + 9
Set colohan = Application.Union(Range(Cells(i, j), Cells(i, j + 1)), Range(Cells(i, karaiti), Cells(i, karaiti + 1)))
colohan.Interior.ColorIndex = 35
End If
Next j
If hit(i - 1, 1) = 1 And hit(i - 1, 5) = 31 Then
Set colohani = Application.Union(Cells(i, 2), Cells(i, 6), Cells(i, 10), Cells(i, 40))
colohani.Interior.ColorIndex = 35
End If
If i = 1000 Then Exit Do
i = i + 1
Loop
Range(Cells(i, j), Cells(i, j + 1)).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub syoukyo()
Range("J2:An1000").Select
Selection.ClearContents
Range("J2").Select
End Sub
'------------------------------------------------------------------------
Sub filter()
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=7
Selection.AutoFilter Field:=8
Selection.AutoFilter Field:=9
Selection.AutoFilter Field:=10
Selection.AutoFilter Field:=11
Selection.AutoFilter Field:=12
Selection.AutoFilter Field:=13
Selection.AutoFilter Field:=14
Selection.AutoFilter Field:=15
Selection.AutoFilter Field:=16
Selection.AutoFilter Field:=17
Selection.AutoFilter Field:=18
Selection.AutoFilter Field:=19
Selection.AutoFilter Field:=20
Selection.AutoFilter Field:=21
Selection.AutoFilter Field:=22
Selection.AutoFilter Field:=23
Selection.AutoFilter Field:=24
Selection.AutoFilter Field:=25
Selection.AutoFilter Field:=26
Selection.AutoFilter Field:=27
Selection.AutoFilter Field:=28
Selection.AutoFilter Field:=29
Selection.AutoFilter Field:=30
Selection.AutoFilter Field:=31
Selection.AutoFilter Field:=32
Selection.AutoFilter Field:=33
Selection.AutoFilter Field:=34
Selection.AutoFilter Field:=35
Selection.AutoFilter Field:=36
Selection.AutoFilter Field:=37
Selection.AutoFilter Field:=38
Selection.AutoFilter Field:=39
Selection.AutoFilter Field:=40
Selection.AutoFilter Field:=41
Selection.AutoFilter Field:=42
Selection.AutoFilter Field:=43
Selection.AutoFilter Field:=44
Selection.AutoFilter Field:=45
Range("a2").Select
z = 1
Do Until Cells(1 + z, 1) = ""
z = z + 1
Loop
Cells(z + 1, 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 予想番号貼付け()
Dim gyou As long
Dim yosouhitnmb(6) As long
gyou = ActiveCell.Row
If Cells(gyou, 1) > 0 Then MsgBox "過去の当選番号欄です。": End
j = 0
For i = 1 To 31
If Cells(gyou, i + 9) <> "" Then
If i - j > 5 Then MsgBox "データ数がおかしいです。": End
yosouhitnmb(i - j) = i
Else
j = j + 1
End If
Next i
For j = 1 To 5
If yosouhitnmb(j) > 0 Then
Cells(gyou, j + 1) = yosouhitnmb(j)
Else
MsgBox "データ等をチェックして下さい。": End
End If
Next j
Range(Cells(gyou, 2), Cells(gyou, 7)).Select
Selection.Insert Shift:=xlDown
z = 1
Do Until Cells(gyou + z, 2) = ""
z = z + 1
Loop
Cells(gyou + 1, 8) = z - 1
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub r_input()
Application.MoveAfterReturnDirection = xlToRight
End Sub
'------------------------------------------------------------------------
Sub d_input()
Application.MoveAfterReturnDirection = xlDown
End Sub
'------------------------------------------------------------------------
Sub 再罫線()
Range("A1:AZ307").Select
With Selection.Borders(xlLeft)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlRight)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlTop)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlBottom)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
Range("A1").Select
End Sub
'------------------------------------------------------------------------
Sub 当選番号チェック()
Dim retu As long
retu = ActiveCell.Column
no = Application.InputBox("当選数字は", Type:=1)
i = 3
Do Until Cells(i, retu) = ""
For j = 1 To 6
If Cells(i, retu - 1 + j) = no Then
Cells(i, retu - 1 + j).Select
Selection.Font.ColorIndex = 3 '赤
ElseIf Cells(i, retu - 1 + j) = no + 1 Then
If Cells(i, retu - 2 + j) <> no Then
Cells(i, retu - 1 + j).Select
Selection.Font.ColorIndex = 7 '黒
End If
ElseIf Cells(i, retu - 1 + j) = no - 1 Then
Cells(i, retu - 1 + j).Select
Selection.Font.ColorIndex = 7 '紫
End If
Next j
i = i + 1
Loop
Cells(3, retu).Select
End Sub
'------------------------------------------------------------------------
Sub rinput()
Application.MoveAfterReturnDirection = xlToRight
End Sub
Dim retu As long
Dim gyou As long
Sub cunters()
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 = 2000 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub rencunters() '連荘パターン集計
retu = ActiveCell.Column
gyou = ActiveCell.Row
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, retu + 2) = rentyan '連荘合計
End If
End If
If i = 5000 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "データ等をチェックして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub minirotos() 'クイックピック
saikeisanoff
Randomize
Range("a1:b43").Select
Selection.ClearContents
count_5 = 0
For i = 1 To 155
kai = Int(Rnd() * 31) + 1
Cells(kai, 1) = kai
Cells(kai, 2) = i
If Cells(kai, 1) > 0 Then
Cells(kai, 2) = Cells(kai, 2) + 1
End If
Range("c1") = "=count(a1:a31)"
count_5 = Cells(1, 3)
Next i
Range("B1").Select
ActiveWorkbook.Worksheets("QP").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("QP").Sort.SortFields.Add Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("QP").Sort
.SetRange Range("A1:C31")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:A5").Select
ActiveWorkbook.Worksheets("QP").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("QP").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("QP").Sort
.SetRange Range("A1:A5")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("B:C").Select
Selection.ClearContents
Range("A6:A31").Select
Selection.ClearContents
Range("A1:A5").Select
Selection.Copy
Range("G10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("K14,F9:L9,L10:L11,F11:K11,F10,H16:J16").Select
Range("H16").Activate
saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub saikeisanoff()
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
End Sub
------------------------------------------------
Sub saikeisanon()
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = True
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub sheetnamae()
actsheet = ActiveSheet.Name
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub first_検索()
Dim gyou As long, nunban As long, nextbango As long
Range("c2:c800").Select
bango = Application.InputBox("最初の番号は何番ですか ")
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
gyou = ActiveCell.Row
nextbango = Application.InputBox("2番目の番号は何番ですか ")
If bango >= nextbango Then MsgBox "データ等をチェックして下さい。": End
Range(Cells(gyou + 1, 4), Cells(gyou + 800, 4)).Select
Selection.Find(What:=nextbango, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
ngyou = ActiveCell.Row
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hotno_sin()'出目を赤色にする。シート(分析 (2)(分析).(分析 (3))
Dim maruiti As Object
Sheets("分析 (2)").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析").Select
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析 (3)").Select
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析 (2)").Select
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
Cells(gyou + j, retu).Select
End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hotno_sinkkk()
Dim maruiti As Object
Sheets("分析").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析 (2)").Select
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析 (3)").Select
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 3
Sheets("分析").Select
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
Cells(gyou + j, retu).Select
End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
同伴数字(ペア数字)を集計する。ボーナス数字含む
Sub dou_han() '同伴数字を集計する。
Sheets("元データ").Select
Range("B2:G1000").Select
Selection.Copy
Sheets("同伴数字").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("K4:AO34").Select
Selection.ClearContents
Cells(1, 8) = "? 回"
i = 1
Do Until Cells(i, 1) = ""
For a = 1 To 5 '1,2,3,4,5
xa = Cells(i, 1) '最初数字
ya = Cells(i, a + 1) '次回以降数字
Cells(ya + 3, xa + 10) = Cells(ya + 3, xa + 10) + 1'追加する
Cells(xa + 3, ya + 10) = Cells(xa + 3, ya + 10) + 1
Next a
For b = 1 To 4 '2,3,4,5
xa = Cells(i, 2)
ya = Cells(i, b + 2)
Cells(ya + 3, xa + 10) = Cells(ya + 3, xa + 10) + 1
Cells(xa + 3, ya + 10) = Cells(xa + 3, ya + 10) + 1
Next b
For c = 1 To 3 '3,4,5
xa = Cells(i, 3)
ya = Cells(i, c + 3)
Cells(ya + 3, xa + 10) = Cells(ya + 3, xa + 10) + 1
Cells(xa + 3, ya + 10) = Cells(xa + 3, ya + 10) + 1
Next c
For d = 1 To 2 '4,5
xa = Cells(i, 4)
ya = Cells(i, d + 4)
Cells(ya + 3, xa + 10) = Cells(ya + 3, xa + 10) + 1
Cells(xa + 3, ya + 10) = Cells(xa + 3, ya + 10) + 1
Next d
xa = Cells(i, 5) '5
ya = Cells(i, 6)
Cells(ya + 3, xa + 10) = Cells(ya + 3, xa + 10) + 1
Cells(xa + 3, ya + 10) = Cells(xa + 3, ya + 10) + 1
i = i + 1
Loop
Cells(1, 8) = i - 1 & "回"
Range("j3").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
前回と今回が同じ当選数字の場合多重当選とする。ボーナス数字含む
Sub Minitajyuucopy() '多重当選の計算する。
Range("BJ2:Cn1003").Select
Selection.ClearContents
saikeisanoff
For n = 1 To 31
i = 1
Do Until Cells(i + 1, 5) = ""
If Cells(i + 1, 9 + n) <> "" Then
Cells(i + 1, 61 + n) = 1
End If
If i = 1000 Then Exit Do
i = i + 1
Loop
Next n
For m = 1 To 31
i = 1
Do Until Cells(i + 1, 5) = ""
If Cells(i + 1, 61 + m) >= 1 Then '多重カウントする。
If Cells(i + 2, 61 + m) = 1 Then
Cells(i + 2, 61 + m) = Cells(i + 1, 61 + m) + 1
Cells(i + 1, 61 + m) = ""
End If
End If
If i = 1000 Then Exit Do
i = i + 1
Loop
Next m
Cells(i, 2).Select
saikeisanon
End Sub