趣味のエクセルマクロ

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

1.LOTO6

'マクロ実行-------表示パターン選択-------パターンで表示する
Public pata_1, pata_2 As String
Public pata_f As Integer
Dim hit(1100, 7) As Integer
Dim retu As Integer
Dim gyou As Integer
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 Integer
   Dim yosouhitnmb(6) As Integer
   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 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 cunters()
 Dim retu As Integer
 Dim gyou As Integer

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
--------------------------------------------------------------------------------------------------