1.LOTO6
'マクロ実行-------表示パターン選択-------パターンで表示する
Public pata_1 As String, pata_2 As String
Public pata_f As long
Dim hit(1100, 7) As long
Dim retu As long
Dim gyou As long
Dim carahan As Object
Dim carahani As Object
--------------------------------------------------------------------------------------------------
Sub patapata() 'ロト6当選数字パターン(6種類から選択)貼付け
saikeisanoff ’再計算を止めて処理スピードアップする。
Erase hit: pata_1 = "": pata_2 = "": pata_f = 0
UserForm1.Show 'ユーザーホームを開くーーパターン選択
Call syoukyo ’データ消去サブプログラム呼び出し
actsheet = ActiveSheet.Name
If actsheet <> "リスト2" Then '元データをコピーする。
Sheets("元データ").Select
Range("d2:k1100").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 7
If Cells(i, j + 1) <= 0 Or Cells(i, j + 1) >= 44 Then MsgBox i - 1 & "回のデータが不正です": End
hit(i - 1, j) = Cells(i, j + 1)
If j > 1 And j < 7 And hit(i - 1, j - 1) >= hit(i - 1, j) Then MsgBox i - 1 & "回のデータが不正です": End
Next j
If i = 1500 Then Exit Do
i = i + 1
k = i
Loop
For i = 1 To k - 2
For j = 1 To 7
If pata_f = 1 Then
If j = 7 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 = 7 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
Range("J2:AZ1100").Select
Range("J1:r1100,ac1:Al1000,Aw1:AZ1000").Select
Range("Aw1").Activate
Call renpata '連番数字 サブマクロプログラム
Cells(i + 1, 9).Select
saikeisanon’再計算をする。
End Sub
--------------------------------------------------------------------------------------------------
Sub renpata() '連番数字 サブマクロプログラム
Columns("B:G").Select
Selection.Interior.ColorIndex = xlNone
i = 2
Do Until Cells(i, 2) = ""
For j = 6 To 2 Step -1
If hit(i - 1, j) - hit(i - 1, j - 1) = 1 Then '連番部を緑色に塗りつぶす
karaiti = Cells(i, j) + 9
Set carahan = Application.Union(Range(Cells(i, j), Cells(i, j + 1)), Range(Cells(i, karaiti), Cells(i, karaiti + 1)))
carahan.Interior.ColorIndex = 35
End If
Next j
If hit(i - 1, 1) = 1 And hit(i - 1, 6) = 43 Then '1,43の連番部を緑色に塗りつぶす
Set carahani = Application.Union(Cells(i, 2), Cells(i, 7), Cells(i, 10), Cells(i, 52))
carahani.Interior.ColorIndex = 35
End If
If i = 1100 Then Exit Do
i = i + 1
Loop
End Sub
'------------------------------------------------------------------------
Sub syoukyo()’データ消去サブプログラム
Range("J2:AZ1000").Select
Selection.ClearContents
Range("J2").Select
End Sub
'------------------------------------------------------------------------
Sub filter()
For ff = 1 To 59
Selection.AutoFilter Field:=ff
Next ff
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 43
If Cells(gyou, i + 9) <> "" Then
If i - j > 6 Then MsgBox "データ数がおかしいです。": End
yosouhitnmb(i - j) = i
Else
j = j + 1
End If
Next
For j = 1 To 6
If yosouhitnmb(j) > 0 Then
Cells(gyou, j + 1) = yosouhitnmb(j)
If Cells(gyou, 7) = 0 Then
Cells(gyou, 7) = 1
End If
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 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 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 cunters()
Dim retu As long
Dim gyou As long
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
End Sub
--------------------------------------------------------------------------------------------------
Sub dayplus6()’日付を追加する--月曜&木曜
gyou = ActiveCell.Row
Cells(gyou - 1, 3).Copy Cells(gyou, 3)
Cells(gyou, 3) = Cells(gyou, 3) + 4
Cells(gyou + 1, 3) = Cells(gyou, 3) + 3
End Sub
--------------------------------------------------------------------------------------------------
Sub rotos() 'クイックピック
saikeisanoff
Randomize
Range("a1:b43").Select
Selection.ClearContents
count_6 = 0
Add = Int(Rnd() * 43) + 1
For i = 1 To 400 + Add
kai = Int(Rnd() * 43) + 1
Cells(kai, 1) = kai
If Cells(kai, 1) > 0 Then
ran = Int(Rnd() * 100) + 1
Cells(kai, 2) = ran ' Cells(kai, 2) + 1
End If
Range("c1") = "=count(a1:a43)"
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:C43")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:B6").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:B6")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("B:B").Select
Selection.ClearContents
Range("A7:A43").Select
Selection.ClearContents
Range("A1:A6").Select
Selection.Copy
Range("G15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Selection.Copy
Range("G10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
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 = False
End Sub
--------------------------------------------------------------------------------------------------
Sub hotno_sin() ’ホットナンバー(目視で判別する)を赤色にする。複数シートを同時に
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("表 (2)").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 B_H() 'ブラックホール(ボーナス数字含むとする) 手動指定場所を塗りつぶす。
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End Sub
--------------------------------------------------------------------------------------------------