趣味のエクセルマクロ

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

1.miniloto

Public pata_1, pata_2 As String
Public pata_f As Integer
Dim hit(1000, 7) As Integer
Dim retu As Integer
Dim gyou As Integer
Dim colohani As Object
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー

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 Integer
Dim yosouhitnmb(6) As Integer
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 Integer
 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 Integer
Dim gyou As Integer
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, nunban, nextbango As Integer
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,6
       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,6
     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,6
    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,6
 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,6
 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