趣味のエクセルマクロ

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

1.No.3 分析

Dim hit_m(10000, 3) As String
Dim kiguu(10000, 3) As String '奇数偶数3桁用文字配列変数
Dim hit(10000, 3) As Integer ’出目3桁用整数配列変数
Dim hitx(10000, 3) As Integer
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

あたまに ' がついた式は実行されない。(緑色部分)
'当選番号は文字として入力、3つに分けて合計、出目から大小や奇数遇数判定
’回号から間隔算出

Sub patapata_3() 'ボックス当選数字パターン貼付け
Dim i, j, dai, lastkai As Integer ’整数変数
Dim daida As String  '文字変数
Sheets("原本").Select  'シートを選択する。選択しない場合他のシートで実行された時は  問題発生危険あり。
lastkai = Cells(1, 12) + 3 '12列目1行目の=SUBTOTAL(2,E3:E5000)と+3で最終回算出
                   'Cells(行, 列)でセルの番地指定、行, 列には変数を入れ変化に対応させる。

    start = MsgBox("開始しますか?", vbYesNo)
If start = vbNo Then End '開始しないで終了する
  saikeisanoff '再計算止めて処理スピード上げる
Range("by3:cj5000").ClearContents ’この範囲をクリア(消す)する。
  Erase hit '変数の内容を消す
Range(Cells(3, 4), Cells(lastkai, 4)).Select 'セルD3~最終回まで複数セル選択する。
Selection.Copy ’選択部をコピー、マクロ自動記録で作成
 Range("BX3").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
  i = 3 ’3行目から開始する
Do Until Cells(i, 7) = "" '7列目の3行目からデータの終わり行までカウンターとして以下の処理をする 空行の場合処理終了する。
     dai = 0 '大小判定用変数を0にする。
   For j = 1 To 3 ’3桁分の処理を繰り返す(jを1~3回までForからNextの間)
    hit(i - 1, j) = Cells(i, j + 4) ’セル5から7列目の3行目からデータを変数に格納する。3桁を1桁づつに計算式で分解しておく。
    If hit(i - 1, j) >= 5 Then dai = dai + 1 ’出目5以上を計算する。
    kiguu(i - 1, j) = Cells(i, j + 8) ’Cells(i, j + 8)のiは i=i+1で1ケづつ処理
   If kiguu(i - 1, j) = "偶" Then kiguu(i - 1, j) = "▲" Else kiguu(i - 1, j) = "△" ’奇数偶数
   If j = 3 Then
    Cells(i, 91) = kiguu(i - 1, 1) + kiguu(i - 1, 2) + kiguu(i - 1, 3)’奇数偶数パターン表示する
   End If
 Next j
   Select Case dai
     Case 0 ’daiの値0で文字変数daida に "■■■" を入れる。           
      daida = "■■■" ’4以下3つを表す
     Case 1
      daida = "■■□" ’4以下2つ’5以上1つ
     Case 2
      daida = "■□□" ’4以下1つ’5以上3つ
     Case 3
      daida = "□□□" ’5以上3つ
   End Select
     Cells(i, 89) = daida 'i行89列に大小(■□)記号を入力する。
  If i = 5000 Then Exit Do ’Do Until Cells(i, 7) = "" からLoopのストッパーとする
    i = i + 1 ’iは3+1で4になる。その後1ケづつ増えて行く
   k = i
Loop  ’Do Until Cells(i, 7) = "" からLoopの間繰り返しの処理をする。
   witi = 77
For i = 2 To k - 2 ’出目に応じた位置にマークする。 
 For j = 1 To 3
   If Cells(i + 1, witi + hit(i, j)) = "" Then ’出目0の時77+0で77列
      Cells(i + 1, witi + hit(i, j)) = "●"  ’シングルを表す
   ElseIf Cells(i + 1, witi + hit(i, j)) = "●" Then
     Cells(i + 1, witi + hit(i, j)) = "◎" ’ダブル
     Cells(i + 1, witi + 11) = 2 ’ダブル
  ElseIf Cells(i + 1, witi + hit(i, j)) = "◎" Then
     Cells(i + 1, witi + hit(i, j)) = "☆" ’トリプル
     Cells(i + 1, witi + 11) = 3 ’トリプル
  End If
 Next j
Next i
saikeisanon
 Call box_3 'サブプログラムSub box_3()呼び出すCallは無くても良い
 Call 当選番号表示
 Call 入力へ
End Sub
------------------------------------------
Sub box_3()
     saikeisanoff
    Dim moji(5000) As String
    Dim gogucara, minigogucara, mini2gogucara, minipgogucara As Object
    Dim rencyan As Integer
    Erase hit_m
i = 3
Do Until Cells(i, 5) = ""
  For j = 1 To 3
     hit(i - 2, j) = Cells(i, j + 4)
  Next j
For k = 1 To 2
  For j = 1 To 2 '数字の大小を判断する。
    If hit(i - 2, j) > hit(i - 2, j + 1) Then
       daisyou = hit(i - 2, j)
       hit(i - 2, j) = hit(i - 2, j + 1)
      hit(i - 2, j + 1) = daisyou
    End If
  Next j
Next k
For j = 1 To 3 '小さい順にボックス数字とする。
      moji(i) = Trim(moji(i)) + Trim(Str(hit(i - 2, j)))
   If j = 3 Then
     Cells(i, 93) = moji(i)
     Cells(i, 94) = Application.CountIf(Range(Cells(2, 93), Cells(i, 93)), Cells(i, 93))
   End If
 Next j
 If i = 5000 Then Exit Do
   i = i + 1
  For x = 1 To 10 '連荘数
     If Cells(i + 1, 76 + x) <> "" And Cells(i + 2, 76 + x) <> "" Then
           rencyan = rencyan + 1
     End If
  Next x
    If rencyan > 0 Then Cells(i + 2, 87) = rencyan
   rencyan = 0
Loop
Cells(i, 26).Select
saikeisanon
End Sub   
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
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_30() 'ストレート当選数字パターン貼付け
Dim hitx(5000, 4), i, j As Integer
If Cells(2, 13) > Sheets("原本").Cells(1, 24) Then MsgBox ("原本フィルター戻して下さい?"): End
start = MsgBox("ストレートパターン開始しますか?", vbYesNo)
  If start = vbNo Then End
   Sheets("原本").Select
    lastkai = Cells(1, 12) + 2
     Range(Cells(3, 4), Cells(lastkai, 4)).Select
     Selection.Copy
    Sheets("すとれ-と").Select
Range("c4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call saikeisanoff
Erase hitx: i = 0: j = 0
   i = 4
Do Until Cells(i, 3) = ""
 For j = 1 To 3 '桁別に
  Select Case j
 Case 1: span = 16’百桁
 Case 2: span = 26’十桁
 Case 3: span = 36’一桁
  End Select
   hitx(i - 3, j) = Cells(i, j + 3) + span
 Next j
   i = i + 1
   k = i
  If i = 5000 Then Exit Do
Loop
   m = 0: l = 0
For l = 1 To k - 4
 For m = 1 To 3
    Cells(l + 3, hitx(l, m)) = "●"
 Next m
Next l
Call saikeisanon
     Call 入力へ
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub cunters() '飛び期間を記入する
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
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 mini_kensaku()
Dim hani, kaigo, gyou, iti, retu As Integer
Sheets("ミニ出現数 ").Select
  Range("B3:b103").Select
  kaigou = Cells(1, 2)
mino = Worksheets("原本").Cells(kaigou + 2, 6) & Worksheets("原本").Cells(kaigou + 2, 7)
  bango = Application.InputBox("番号入力して下さい", Default:=mino)
If Len(bango) > 2 Then MsgBox ("2桁?"): End
Selection.Find(What:=bango, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
  retu = ActiveCell.Column'現在の列
  gyou = ActiveCell.Row'現在の行
  iti = Cells(gyou, 3) + 4
Range(Cells(gyou, iti), Cells(gyou, iti)).Select
 kaigo = Application.InputBox("回号入力して下さい", Default:=kaigou)
 start = MsgBox("開始しますか?", vbYesNo)
   If start = vbNo Then End
   Cells(gyou, iti) = kaigo
   hani = kaigo - Cells(gyou, iti - 1) '前回からの間隔で色付けする。
If hani <= 50 Then ’50回以下
   Cells(gyou, iti).Select
   Selection.Font.ColorIndex = 10 '緑4
ElseIf hani > 50 And hani <= 100 Then
   Cells(gyou, iti).Select
   Selection.Font.ColorIndex = 1 '青53=茶黒1
ElseIf hani >= 101 And hani <= 300 Then
  Cells(gyou, iti).Select
  Selection.Font.ColorIndex = 3 '赤
ElseIf hani > 300 Then
  Cells(gyou, iti).Select
  Selection.Font.ColorIndex = 3 '赤
  Selection.Font.Bold = True
End If
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub plascunt()
Dim p_0 As Integer
  retu = ActiveCell.Column
gyou = ActiveCell.Row
p_0 = Cells(gyou, retu)
Cells(gyou + 1, retu) = p_0 + 1
End Sub
ーーーーーーーーーーーーーーーー
Sub 横詰め並べ()
retu = ActiveCell.Column
gyou = ActiveCell.Row
kijyun = Cells(1, 1)
gejyun = Cells(gyou, 1)
Range(Cells(gyou, 3), Cells(gyou, gejyun + 2)).Select
Selection.Cut
Cells(gyou, kijyun - gejyun + 2).Select
ActiveSheet.Paste
Cells(gyou + 1, 3).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub 空白除去()
Dim x, i, k As Integer
Sheets("すとれ-と").Select
Range("db4:ee1000").ClearContents
saikeisanoff
For x = 1 To 30
   i = 0: k = 0
  Do Until Cells(4 + i, 3) = ""
   If Cells(4 + i, 61 + x) <> "" Then
       Cells(4 + i - k, 105 + x) = Cells(4 + i, 61 + x)
   Else
      k = k + 1
   End If
    If i = 5000 Then Exit Do
    i = i + 1
Loop
Next x
 If i = 0 Then MsgBox "データ等をチェックして下さい。": End
   saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 後飛び記入() '記入する行をクリックした後マクロ実行する。
   gyou = ActiveCell.Row
  If gyou <= 3 Or Cells(gyou, 16) <> "" Then End
For i = 1 To 40
 If Cells(gyou, 15 + i) <> "●" Then
   Cells(gyou, 15 + i) = Cells(gyou - 1, 15 + i) + 1
 ElseIf Cells(gyou - 1, 15 + i) = "●" Then
  Cells(gyou, 15 + i) = 1
 End If
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 飛び記入_3() '記入する行をクリックした後マクロ実行する。
retu = ActiveCell.Column
gyou = ActiveCell.Row
For i = 0 To 30
If Cells(gyou - 1, 16 + i) = "●" Then
  If Cells(gyou, 16 + i) = "" Then Cells(gyou, 16 + i) = 1
Else
  If Cells(gyou, 16 + i) = "" Then Cells(gyou, 16 + i) = Cells(gyou - 1, 16 + i) + 1
End If
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub gokei_color()  '合計変化(右側線)=上昇-赤色、下降-黒色、同じー点線
Dim retu As Integer
saikeisanoff
ActiveWorkbook.Worksheets("原本").Select
  gyou = ActiveCell.Row
  retu = ActiveCell.Column '90,103
 If gyou <= 2 Then End
i = 1
Do Until Cells(i + gyou, retu) = ""
  saki = Cells(i + gyou - 1, retu)
 If saki = Cells(i + gyou, retu) Then
   Cells(i + gyou, retu).Select
   With Selection.Borders(xlEdgeRight)
 .LineStyle = xlContinuous
 .ColorIndex = 0
 .Weight = xlHairline
 End With
ElseIf saki < Cells(i + gyou, retu) Then
  Cells(i + gyou, retu).Select
  With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 10
 End With
ElseIf saki > Cells(i + gyou, retu) Then
     Cells(i + gyou, retu).Select
  With Selection.Borders(xlEdgeRight)
 .LineStyle = xlContinuous
 .ColorIndex = xlAutomatic
  End With
End If
   i = i + 1
If i = 5000 Then Exit Do
Loop
If retu = 90 Then
 retu = 105
ElseIf retu = 105 Then
 retu = 106
End If
 Cells(gyou, retu).Select
 saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Private Sub CommandButton1_Click()
If patann = 0 Then MsgBox ("選択して下さい"): Exit Sub
Unload UserForm1 'ユーザーホームを閉じる
Exit Sub
End Sub
---------------------------
Private Sub CommandButton2_Click()
End
End Sub
---------------------------
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then patann = 1
End Sub
---------------------------
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then patann = 2
End Sub
---------------------------
Private Sub OptionButton3_Click()
If OptionButton3.Value = True Then patann = 3
End Sub
---------------------------
Private Sub OptionButton5_Click()
End Sub
---------------------------
Private Sub TextBox2_Change()
End Sub
---------------------------
Private Sub TextBox3_Change()
End Sub
---------------------------
Private Sub UserForm_Click()
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub kankaku_cunters()
retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
For i = 1 To 777
  If Cells(gyou + i, retu) = "" Then
     j = j + 1
  Else
    Exit For
  End If
Next i
 MsgBox "間隔は " & (j)
 If i = 999 Then End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub tyusyutu_3() '回数間隔ごとに桁別出現
Dim kai, i, ii, r, t, span, owari As Integer
Sheets("すとれ-と").Select
Range("kc4:lg3737").ClearContents
    Cells(3, 289) = Empty
i = 4
kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
If kai = False Or kai = "" Then End
owari = Cells(2, 13) + kai
Cells(3, 289) = kai
Call saikeisanoff '再計算を止めて計算を速くする
For ii = 0 To owari Step kai
  For r = 0 To 2
    Select Case r '百,十,一,のデータ表示列位置の設定
      Case 0: span = 290 '百
      Case 1: span = 300 '十
     Case 2: span = 310 '一
   End Select
  For t = 0 To 9
Cells(i, t + span) = Application.CountIf(Range(Cells(4 + ii, r + 4), Cells(ii + kai + 3, r + 4)), t)
  Next t
 Next r
   If ii > 0 Then Cells(i - 1, 289) = ii
  i = i + 1
Next ii
Call saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                    
Sub 回別スペース集計() '回数間隔ごとに出現集計
Dim kai, i, ii, r, t, span, owari As Integer
     Sheets("原本").Select
Range("mk3:mu3737").ClearContents
    Cells(1, 349) = Empty
 i = 3
 kai = Application.InputBox("集計間隔を入力して下さい", Default:=10)
 If kai = False Or kai = "" Then End
 owari = Cells(1, 12) + kai
 Cells(1, 349) = kai & " 回毎"
 Call saikeisanoff '再計算を止めて計算を速くする
For ii = 3 To owari Step kai
 For t = 0 To 9
    Cells(i, t + 350) = Application.CountIf(Range(Cells(ii, 106), Cells(ii + kai - 1, 106)), t)
 Next t
  If ii > 3 Then Cells(i - 1, 349) = ii - 3
  i = i + 1
Next ii
  Call saikeisanon '再計算を設定する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                            
Sub ST後追い集計_3()
Sheets("すとれ-と").Select
Range("oi5:or14").Select
Selection.ClearContents
Range("oa15") = "=d4"
Range("ob15") = "=d5"
Range("oc15") = "=e4"
Range("od15") = "=e5"
Range("oe15") = "=f4"
Range("of15") = "=f5"
Range("oa15:of15").Select
Selection.Copy
Range("oa16:of3806").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Call saikeisanoff
    ii = 0
For ii = 0 To 4
    j = 0
 For i = 1 To 3
     x = Cells(15 + ii, i + 390 + j)
     y = Cells(15 + ii, i + 391 + j)
    Cells(y + 5, x + 399) = Cells(y + 5, x + 399) + 1
    j = j + 1
 Next i
   Cells(2, 399) = ii + 1
Next ii
 Call saikeisanon
 Range("oh4").Select
End Sub
ーーーーーーーーーーーーーーーー

Sub deme_uesita_3()’出目を指定後上下の出目を出す
Dim deme, j, i, kaigou, gyou_deme, retu_deme As Integer
 Worksheets("すとれ-と").Select
kaigou = Cells(2, 13)
Range("pp4:ps5000").Select
Selection.ClearContents
Range(Cells(4, 4), Cells(3 + kaigou, 7)).Select
Selection.Copy
Range("pk4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
   deme = Cells(2, 433)
   i = 1
Do Until Cells(3 + i, 429) = ""
  For j = 1 To 3
    If Cells(4 + i, 426 + j) = deme Then
  Cells(3 + i, 431 + j) = Cells(3 + i, 426 + j)
       Cells(4 + i, 431 + j) = deme
       Cells(5 + i, 431 + j) = Cells(5 + i, 426 + j)
    End If
  Next j
    i = i + 1
   If i > 5000 Then Exit Do
Loop
Cells(i - 7, 431).Select
End Sub