趣味のエクセルマクロ

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

1.ナンバーズ4パターン表作成関係エクセルマクロ(1) 



Public patann As Integer
 Public patan As Integer
 Dim stcolo As Range
 Dim goguucara As Range
 Dim tokiguu As Integer
 Dim kiguu(4) As String
 Dim hit(5000, 4) As Integer
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
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
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー



当選番号から出目パターン、合計、大小、奇遇、ボックス回数、シングルダブル、等を表示させる。
Sub patapata_4() '当選数字パターン貼付け(引張表作成)
 Dim i, j, k, dbl, kaigou As Integer
 Dim daida, Db As String
start = MsgBox("開始しますか?", vbYesNo)’マクロボタン押下でメッセージ出す
 If start = vbNo Then End ’中止する時
Worksheets("パターン表").Select
kaigou = Cells(1, 26)  ’回号を変数に入れる。
Range(Cells(2, 17), Cells(kaigou + 1, 17)).Select
Selection.Copy
Range("BN2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Bo2:Bz4500", "ca2:ca4500").Select ' 出目パターン表示部をクリアする
Selection.ClearContents
Application.ScreenUpdating = False '画面変更をしない。
Call saikeisanoff
 Range("BW2").Activate
 Erase hit ’配列変数の内容をクリア(取りあえずw)
i = 2
Do Until Cells(i, 18) = "" ’ Cells(i, 18)のデータが無くなる迄下の処理をする。
dai = 0
For j = 1 To 4 ' 4つの出目の配列変数への入力
   hit(i - 1, j) = Cells(i, j + 17)
      If hit(i - 1, j) >= 5 Then dai = dai + 1 ’出目の大小、5以上の集計
      kiguu(j) = Cells(i, j + 21)
       If kiguu(j) = "偶" Then kiguu(j) = "▲" Else kiguu(j) = "△"
  If j = 4 Then ’4つの出目の奇遇偶数を集計する
 Cells(i, 81) = kiguu(1) + kiguu(2) + kiguu(3) + kiguu(4)
  End If
Next j
    Select Case dai '大小の表示
      Case 0: daida = "■■■■" ’4以下4つの時
      Case 1: daida = "■■■□" ’4以下3つの時
      Case 2: daida = "■■□□" ’4以下2つの時
      Case 3: daida = "■□□□" ’4以下1つの時
      Case 4: daida = "□□□□" ’4以下0の時
   End Select
Cells(i, 79) = daida
i = i + 1 ’ Cells(i, 18) のiの部分が1づつ増えて行く(下の行に向かっていく)
k = i
If i = 4501 Then Exit Do
Loop
witi = 67 ’表示する列のスタート位置----出目0の時は67列目
For i = 1 To k - 2
For j = 1 To 4 '出目パターン作成(4出目分)
If Cells(i + 1, witi + hit(i, j)) = "" Then
   Cells(i + 1, witi + hit(i, j)) = "●"
ElseIf Cells(i + 1, witi + hit(i, j)) = "●" Then
   Cells(i + 1, witi + hit(i, j)) = "◎" ’ダブルの時◎にする。
    dbl = dbl + 1
      If dbl = 1 Then Db = "2" Else Db = " d2"
    Cells(i + 1, witi + 11) = Db  
ElseIf Cells(i + 1, witi + hit(i, j)) = "◎" Then
   Cells(i + 1, witi + hit(i, j)) = "☆" ’トリプルの時☆にする。
   Cells(i + 1, witi + 11) = 3
ElseIf Cells(i + 1, witi + hit(i, j)) = "☆" Then
   Cells(i + 1, witi + hit(i, j)) = "★" ’フォースの時
   Cells(i + 1, witi + 11) = 4
End If
Next j
dbl = 0  
Next i
Call box 'ボックス回数カウント等  Sub box()を呼び出して実行させる。 
Application.ScreenUpdating = True
Call 当選番号表示’サブルーチン(サブプログラム)呼び出す
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
'当選番号を小さい順に並び替えて、該当番号の累計出現回数を計算
 ストレート番号が何回出たかを色別の縦線で表示


Sub box() 
Dim moji(5000) As String
Dim i, j, x, rencyan, caler As Integer
Range("ce2:ce5000").Select
Selection.NumberFormatLocal = "@"
Selection.ClearContents
i = 2
Do Until Cells(i, 18) = ""
For k = 1 To 3
  For j = 1 To 3
      If hit(i - 1, j) > hit(i - 1, j + 1) Then ’出目を小さい順に並びかえする。
      daisyou = hit(i - 1, j)
    hit(i - 1, j) = hit(i - 1, j + 1)
    hit(i - 1, j + 1) = daisyou
      End If    
  Next j
Next k
For j = 1 To 4 ’当選番号をボックス番号にする(小さい順に並べて)
    moji(i) = Trim(moji(i)) + Trim(Str(hit(i - 1, j)))
If j = 4 Then 'ボックス累計回数計算 
Cells(i, 83) = moji(i) ’ボックス(bkとする)番号表示する
Cells(i, 84) = Application.CountIf(Range(Cells(2, 83), Cells(i, 83)), Cells(i, 83))  ’bk回数   
End If
Next j
     caler = Application.CountIf(Range(Cells(2, 66), Cells(i, 66)), Cells(i, 66)) 
   Set stcolo = Application.Cells(i, 66)
  stcolo.Borders(xlEdgeLeft).ColorIndex = 1
If caler = 2 Then 'ストレート2回目当選番号の左の線を黄色にする       
  stcolo.Borders(xlEdgeLeft).ColorIndex = 4
ElseIf caler = 3 Then 'ストレート3回目当選番号の左の線を赤色にする    
  stcolo.Borders(xlEdgeLeft).ColorIndex = 3       
ElseIf caler >= 4 Then 'ストレート4回目以上両脇赤色にする     
  stcolo.Borders(xlEdgeLeft).ColorIndex = 3
  stcolo.Borders(xlEdgeRight).ColorIndex = 3      
End If
For x = 1 To 10 '連荘数      
  If Cells(i, 66 + x) <> "" And Cells(i + 1, 66 + x) <> "" Then
    rencyan = rencyan + 1       
  End If
Next x
If rencyan > 0 Then Cells(i + 1, 77) = rencyan     
rencyan = 0
  If i = 5000 Then Exit Do
i = i + 1
Loop
Range(Cells(i, 80), Cells(i, 80)).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー  Sub 当選番号表示()'たとえば6731を6 7 3 1にしたのをコピー 
Worksheets("パターン表").Range("GM2:GM5000").Copy
lasty = Cells(1, 26) + 1
Range("bn2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(lasty, 66).Select
End Sub  
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub box間隔2k()'上手く動かないのでbox間隔マクロを2回計算している。
box間隔
box間隔
End Sub
--------------------------------------
 Sub box間隔() 'box間隔計算
Dim i, k, gyou As Integer
Dim boxspan As String
Worksheets("パターン表").Select
gyou = ActiveCell.Row
If Cells(gyou, 84) = 0 Then End
  boxspan = Cells(gyou, 83)
Application.ScreenUpdating = False '画面変更をしない。
If Cells(gyou, 84) = 1 Then '始めてなら
Cells(gyou, 115) = gyou - 1
If gyou > 2000 Then '2000回以降に出たら二重線を引く
Cells(gyou, 115).Select
Selection.Font.Underline = xlUnderlineStyleDouble
End If
Exit Sub
End If
   i = 1
Do Until boxspan = Cells(gyou - i, 83)
i = i + 1
If i = 3333 Then Exit Do
Loop
Cells(gyou, 115) = i '間隔記入する
Cells(gyou - i, 78).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 78).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(gyou - i, 83).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 83).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 84).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 84).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 103).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 103).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(gyou - i, 115).Select
Selection.Copy '前回のパターンをコピーする。
Cells(gyou, 115).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
  Range(Cells(gyou - i, 116), Cells(gyou - i, 121)).Select
Selection.Copy '欠け算コピー
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 116), Cells(gyou, 127)).Select
  Selection.Font.Underline = xlUnderlineStyleNone
Range("DL11:EB11").Select '10回出目からINTまで計算式コピーする。
Selection.Copy
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 116), Cells(gyou, 132)).Select
Selection.Copy
Cells(gyou, 116).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False            
Range("da11:dj11").Select '計算式コピーする。
Selection.Copy
Cells(gyou, 105).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 105), Cells(gyou, 114)).Select
Selection.Copy
Cells(gyou, 105).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False       
Range("cv11:cy11").Select '全中後連番まで計算式コピーする。
Selection.Copy
Cells(gyou, 100).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(Cells(gyou, 100), Cells(gyou, 102)).Select
Selection.Copy
Cells(gyou, 100).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False    
Application.ScreenUpdating = True '画面変更。
Cells(gyou, 83).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

'デジタルナンバーズ考案の強弱順位を手入力後パターン表示
Sub kyoujyaku()
Erase hit
Worksheets("パターン表").Select
start = MsgBox("強弱順位開始しますか?", vbYesNo)
If start = vbNo Then End
 Range("Bd2:Bm5000").Select
Selection.ClearContents
Range("ar2:Ba5000").Select
      With Selection.Font
       .ColorIndex = xlAutomatic
       .TintAndShade = 0
     End With
Call saikeisanoff
Application.ScreenUpdating = False '画面変更をしない。
i = 8
witi = 55
Do Until Cells(i, 18) = ""
For j = 1 To 4
hit(i - 7, j) = Cells(i, j + 17)
For m = 1 To 10
If hit(i - 7, j) = Cells(i - 1, m + 43) Then
    If Cells(i, witi + m) = "" Then
       Cells(i, witi + m) = "●"
    ElseIf Cells(i, witi + m) = "●" Then 
       Cells(i, witi + m) = "◎"
    ElseIf Cells(i, witi + m) = "◎" Then
       Cells(i, witi + m) = "☆"
    ElseIf Cells(i, witi + m) = "☆" Then
       Cells(i, witi + m) = "★"
    End If
End If
Next m
Next j   
For k = 1 To 10
If Cells(i, 55 + k) <> "" Then
     Cells(i, 43 + k).Select   
     With Selection.Font
       .Color = -16776961
       .TintAndShade = 0
     End With              
End If    
Next k     
If i = 5000 Then Exit Do
i = i + 1 
Loop
Application.ScreenUpdating = True '画面変更。
Range(Cells(i, witi), Cells(i, witi)).Select
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hotnum_color()
Dim maruiti As Range
 Dim gyou, retu, yiti As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Object
Worksheets("パターン表").Select
Application.ScreenUpdating = False '画面変更をしない。
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <= 17 Or retu >= 22 Then End
   deme__iti = Cells(gyou, retu) + 67  
deme = Cells(gyou, retu) '出目
If Cells(gyou, retu) > 4 Then
With Selection.Interior
  .Color = 65535
End With
Else
With Selection.Interior
   .Color = 10092543
End With
End If
    Set maruiti = Application.Cells(gyou, deme__iti)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 53
yiti = deme - Cells(gyou, 85) '出目の位置
Cells(gyou + yiti, retu + 70).Select '桁別に88行から出目対応して上に
    With Selection.Interior
  .Color = 10092543
End With     
Sheets("欠け算並び").Cells(gyou + 8, retu + 125) = Worksheets("パターン表").Cells(gyou, retu)
Worksheets("パターン表").Select     
Application.ScreenUpdating = True '画面変更をしない。
Cells(gyou + 1, retu).Select 
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

 ' =COUNTIF($R$4492:$U$4501,AI4501)を=COUNTIF($R$4502:$U$4511,AI4502)に変換


Sub 間隔計算式__置換()   '計算式置換コピーテストWhat:="4302", Replacement:="4312"
Dim gyou, retu As Integer
Worksheets("パターン表").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <> 36 And retu <> 88 Then End
a_gyou = gyou - 10
b_gyou = gyou - 1
c_gyou = gyou + 9
 Cells(gyou, retu).Select
  ActiveCell.Replace What:=a_gyou, Replacement:=gyou, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
  ActiveCell.Replace What:=b_gyou, Replacement:=c_gyou, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

 Sub deme4間隔() 'deme間隔でアンダーバー引く(青色部)
Dim i, k, gyou, retu, deme, ndeme, yiti  As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Range
Worksheets("パターン表").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If ActiveCell.Column <= 137 And ActiveCell.Column >= 142 Then End
   deme = Cells(gyou, retu) '出目
yiti = deme - Cells(gyou, 85) '出目の位置
 Set demebar = Application.Cells(gyou, retu)
Set ndemebar = Application.Cells(gyou + yiti, retu + 70) '桁別に88行から出目対応して上下に
Set tdemebar = Application.Cells(gyou, 116 + deme) '10出目毎に
i = 1 
Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1 
If i = 2000 Then Exit Do
Loop
If k >= 10 And k <= 29 Then
   demebar.Font.Underline = xlUnderlineStyleSingle
   ndemebar.Font.Underline = xlUnderlineStyleSingle
   tdemebar.Font.Underline = xlUnderlineStyleSingle
ElseIf k >= 30 Then
   demebar.Font.Underline = xlUnderlineStyleDouble
   ndemebar.Font.Underline = xlUnderlineStyleDouble
   tdemebar.Font.Underline = xlUnderlineStyleDouble
Else
   demebar.Font.Underline = xlUnderlineStyleNone
   ndemebar.Font.Underline = xlUnderlineStyleNone
End If
  Cells(gyou + 1, retu).Select
'deme4間隔
'  return0

     '自動で脇の桁に移動
   If Cells(gyou + 1, retu) = "" Then
       Cells(gyou, retu + 1).Select
      End
   End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

'奇偶判別 マクロ関数    arg_BNum1が v4344にーー arg_BNum4 がY4344に対応
(マクロで関数を(奇偶並びで16パターン判別用)作成)


Function set_NUFkiguu(arg_BNum1 As String, _
                               arg_BNum2 As String, _
                               arg_BNum3 As String, _
                               arg_BNum4 As String) As Integer                              
Dim kigu As Integer     
   If arg_BNum1 = "奇" And arg_BNum2 = "奇" Then
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 1
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 3
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 4
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 11
   End If  
  If arg_BNum1 = "偶" And arg_BNum2 = "偶" Then
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 2
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 7
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 8
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 14     
   End If  
If arg_BNum1 = "奇" And arg_BNum2 = "偶" Then
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 5
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 12
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 13
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 10
   End If  
If arg_BNum1 = "偶" And arg_BNum2 = "奇" Then
       If arg_BNum3 = "偶" And arg_BNum4 = "偶" Then kigu = 9
       If arg_BNum3 = "偶" And arg_BNum4 = "奇" Then kigu = 15
       If arg_BNum3 = "奇" And arg_BNum4 = "偶" Then kigu = 16
       If arg_BNum3 = "奇" And arg_BNum4 = "奇" Then kigu = 6
   End If
 set_NUFkiguu = kigu
End Function
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

'大小判別 マクロ関数
Function set_NUFdaisyo(arg_BNum As String) As Integer
 Dim daisyo As Integer
daisyo = 0
     If arg_BNum = "□□□□" Then daisyo = 1
     If arg_BNum = "■■■■" Then daisyo = 2
     If arg_BNum = "□□□■" Then daisyo = 3
     If arg_BNum = "□□■□" Then daisyo = 4
     If arg_BNum = "□■□□" Then daisyo = 5
     If arg_BNum = "■□□□" Then daisyo = 6
     If arg_BNum = "■■■□" Then daisyo = 7
     If arg_BNum = "■■□■" Then daisyo = 8
     If arg_BNum = "■□■■" Then daisyo = 9
     If arg_BNum = "□■■■" Then daisyo = 10
     If arg_BNum = "□□■■" Then daisyo = 11
     If arg_BNum = "□■□■" Then daisyo = 12
     If arg_BNum = "□■■□" Then daisyo = 13
     If arg_BNum = "■■□□" Then daisyo = 14
     If arg_BNum = "■□■□" Then daisyo = 15
     If arg_BNum = "■□□■" Then daisyo = 16
set_NUFdaisyo = daisyo
End Function
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー