趣味のエクセルマクロ

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

4.No.3 分析

Sub Copi_propaty()
Dim Maxx, gokeimax, start As Integer
start = MsgBox("「データ集計」を「プロパテイ」にコピーしますか?", vbYesNo)
Call saikeisanoff '再計算を止めて計算を速くする
If start = vbNo Then End
Sheets("プロパテイ").Select
Range("C15:AVF96").ClearContents
Sheets("原本").Select
If Cells(15, 205) <> "" Then MsgBox ("整列してからです"): End
Maxx = Cells(1, 196) + 3
gokeimax = Cells(1, 198)
Range(Cells(2300, 204), Cells(2300 + gokeimax, 223)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(16, Maxx - gokeimax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'-----------------------------------------
Sheets("原本").Select '奇数偶数
kigumax = Cells(1, 239)
Range(Cells(2300, 241), Cells(2300 + kigumax, 248)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
'Range("C43").Select
Cells(43, Maxx - kigumax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'-----------------------------------
Sheets("原本").Select '大小
daisyomax = Cells(1, 259)
Range(Cells(2300, 261), Cells(2300 + daisyomax, 268)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(53, Maxx - daisyomax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'------------------------------
Sheets("原本").Select
minipmax = Cells(1, 278)
Range(Cells(2300, 280), Cells(2300 + minipmax, 298)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Cells(64, Maxx - minipmax).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'----------------------------
Sheets("原本").Select
minismax = Cells(1, 308)
Range(Cells(2300, 310), Cells(2300 + minismax, 319)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("c87").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Cells(1, 1) = Sheets("原本").Cells(1, 197)
Sheets("原本").Select
Range("GV5:HO5").Select
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE16").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("IG5:IN5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE43").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("JA5:JH5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE53").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("JT5:KL5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("原本").Select
Range("KX5:LG5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("プロパテイ").Select
Range("BCE87").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Call saikeisanon '再計算
Range("a3").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub TKGM_seiretu()   '番号,回号、間隔を下並び出力。
Dim gokei_max, kigu_max, daisyo_max, mini_pmax, mini_smax As Integer
Dim i, ii, j, jj, k, start As Integer
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Sheets("原本").Select
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 198)
For i = 0 To 27
        motosuu = Cells(7, i + 200)
      If Cells(2300, i + 200) = "" Then End
If gokei_max > motosuu Then
  Range(Cells(10, i + 200), Cells(gokei_max - motosuu + 9, i + 200)).Select
  Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
kigu_max = Cells(1, 239)
For ii = 1 To 8
motosuu = Cells(7, ii + 240)
If kigu_max > motosuu Then
Range(Cells(10, ii + 240), Cells(kigu_max - motosuu + 9, ii + 240)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next ii
daisyo_max = Cells(1, 259)
For j = 1 To 8
motosuu = Cells(7, j + 260)
If daisyo_max > motosuu Then
Range(Cells(10, j + 260), Cells(daisyo_max - motosuu + 9, j + 260)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next j
mini_pmax = Cells(1, 278)
For jj = 0 To 18
motosuu = Cells(7, jj + 280)
If mini_pmax > motosuu Then
Range(Cells(10, jj + 280), Cells(mini_pmax - motosuu + 9, jj + 280)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next jj
mini_smax = Cells(1, 308)
For k = 0 To 9
motosuu = Cells(7, k + 310)
If mini_smax > motosuu Then
Range(Cells(10, k + 310), Cells(mini_smax - motosuu + 9, k + 310)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next k
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub HotNo_Seiretu()
Sheets("すとれ-と").Select
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Range("ej4:fm1000").Clear
Range("DB2:EE2").Select
Selection.Copy
Range("EJ2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("DB4:EE462").Select
Application.CutCopyMode = False
Selection.Copy
Range("EJ4").Select
ActiveSheet.Paste
gokei_max = Cells(2, 139)
For j = 1 To 30
motosuu = Cells(2, j + 139)
Range(Cells(4, j + 139), Cells(4 + motosuu, j + 139)).Select '番号,
Selection.Cut
Cells(4 + gokei_max - motosuu, j + 139).Select
ActiveSheet.Paste
Next j
Range("EJ4:FM456").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub next_spac() '次spaceを表示する
Sheets("原本").Select
Range("lp4:ly6000").ClearContents '出力表示部のクリア
Call saikeisanoff '再計算を止めて計算を速くする
i = 3
Do Until Cells(i, 106) = ""
retu_1 = Cells(i, 106).Value + 328
nextotal = Cells(i + 1, 106).Value
caunter = Application.Count(Range(Cells(5, retu_1), Cells(500, retu_1)))
Cells(3, retu_1) = caunter
Cells(caunter + 5, retu_1) = nextotal
i = i + 1
If i = 4001 Then Exit Do
Loop
Call saikeisanon '再計算をオンにする
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub nextspac_seiretu3()  
Dim gokei_max As Integer
Dim i, ii, j, jj, k, start As Integer
start = MsgBox("整列開始しますか?", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 338)
For i = 0 To 9
  motosuu = Cells(3, i + 328)
  Range(Cells(5, i + 328), Cells(5 + motosuu, i + 328)).Select '番号,
  Selection.Cut
   Cells(5 + gokei_max - motosuu, i + 328).Select
  ActiveSheet.Paste
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 当選番号表示()
Sheets("原本").Select
lasty = Cells(1, 12) + 3
Range(Cells(3, 157), Cells(lasty, 157)).Select
Selection.Copy
Range("BX3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(lasty, 15).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力赤丸()
Dim maruiti As Range
Sheets("すとれ-と").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
If Cells(gyou, retu) <> "●" Then End
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.Color = -16776961
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_sin()
Dim maruiti As Range
Sheets("原本").Select
retu = ActiveCell.Column
gyou = ActiveCell.Row
Set maruiti = Application.Cells(gyou, retu)
maruiti.Font.Underline = xlUnderlineStyleSingle
maruiti.Font.ColorIndex = 53
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 入力へ()
  actsheet = ActiveSheet.Name
If actsheet = "原本" Then
retu = 12: w = 4: h = 0
ElseIf actsheet = "すとれ-と" Then
retu = 47: w = 3: h = 1
End If
jp = Cells(1, retu) + 3 + h
Cells(jp, w).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 原本へ()
Sheets("原本").Select
End Sub


Sub 二桁へ()
Sheets("二桁").Select
Range("c5").Select
End Sub


Sub laster()
jp = Cells(10, 1) + 7
Cells(jp + 4, 3).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Hotcopy()
Sheets("原本").Select
Range("E3:G5000").Select
Selection.Copy
Range("FJ3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
jp = Cells(1, 24) + 3
Cells(jp, 166).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub l_lin_edrow() '右下に斜めに線を引く
'hippari If retu>75 Then retu = 67: Cells(gyou + 1, retu).Select: End
retu = ActiveCell.Column
gyou = ActiveCell.Row     
With Selection.Borders(xlDiagonalDown)
.LineStyle = xlDot
.Color = -16738048
.TintAndShade = 0
.Weight = xlThin
End With                
If Cells(gyou + 1, retu + 1) <> "" Then
If retu > 85 Then retu = 76
Cells(gyou + 1, retu + 1).Select                
l_lin_edrow                
End If
Cells(gyou + 1, retu + 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub r_line_drow()
'左下に斜め線を引く
retu = ActiveCell.Column
gyou = ActiveCell.Row
With Selection.Borders(xlDiagonalUp)
.LineStyle = xlDot
.Color = -16738048
.TintAndShade = 0
.Weight = xlThin
End With            
If Cells(gyou + 1, retu - 1) <> "" Then
If retu < 78 Then retu = 86: Cells(gyou + 1, retu).Select: End
Cells(gyou + 1, retu - 1).Select
r_line_drow
End If
Cells(gyou + 1, retu - 1).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub deme_st3間隔() 'deme間隔でアンダーバー引く
Dim i, k, gyou, retu, deme, ndeme, yiti  As Integer
Dim demebar, ndemebar, tdemebar, demerenbar As Object
Worksheets("原本").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <= 165 Or retu >= 169 Then End
deme = Cells(gyou, retu)
If deme = "" Then End
Set demebar = Application.Cells(gyou, retu)
Set ndemebar = Application.Cells(gyou, retu + 8)
i = 1
Do Until deme = Cells(gyou - i, retu)
i = i + 1
k = i - 1
If i = 2000 Then Exit Do
Loop
If k >= 11 And k <= 29 Then
demebar.Font.Underline = xlUnderlineStyleSingle
ndemebar.Font.Underline = xlUnderlineStyleSingle
ElseIf k >= 30 Then
demebar.Font.Underline = xlUnderlineStyleDouble
ndemebar.Font.Underline = xlUnderlineStyleDouble
Else
demebar.Font.Underline = xlUnderlineStyleNone
ndemebar.Font.Underline = xlUnderlineStyleNone
End If
If k = 0 Then
Cells(gyou, retu + 8) = 0
Else
Cells(gyou, retu + 8) = k
End If
Cells(gyou + 1, retu).Select
'自動で脇の桁に移動
If Cells(gyou + 1, retu) = "" Then
Cells(gyou - 3, retu + 1).Select
End
End If
deme_st3間隔
'return0
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

  Sub 間隔計算式__置換()   '計算式置換  上の式をコピーした後マクロ実行する。
Dim gyou, retu As Integer
 Worksheets("原本").Select
gyou = ActiveCell.Row
retu = ActiveCell.Column
If retu <> 25  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
   
   Selection.Copy
    Range(Cells(gyou, retu), Cells(gyou + 9, retu)).Select '10行分貼り付け
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub hanntei_2()
Dim hani As Integer
Sheets("ミニ出現数 ").Select
saikeisanoff
For i = 1 To 101
h = 1
 Do Until Cells(2 + i, h + 3) = ""
  If h = 1 Then
      hani = Cells(2 + i, h + 3)
  Else
      hani = Cells(2 + i, h + 3) - Cells(2 + i, h + 2)
  End If
  If hani <= 50 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 10 '緑4
  ElseIf hani > 50 And hani <= 100 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 1 '青53=茶黒1
  ElseIf hani >= 101 And hani <= 300 Then
      Cells(2 + i, h + 3).Select
       Selection.Font.ColorIndex = 3 '赤
  ElseIf hani > 300 Then
      Cells(2 + i, h + 3).Select
      Selection.Font.ColorIndex = 3 '赤
   Selection.Font.Bold = True
   End If
  h = h + 1
  If h = 60 Then Exit Do
 Loop
  h = 0
Next i
  saikeisanon
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub HOTNO_3iroiti()
gyou = ActiveCell.Row
retu = ActiveCell.Column             
Cells(500, retu + 90).Select
i = 0
Do Until Cells(500 + i, retu + 90) <> ""     
  i = i - 1              
 If i < -500 Then Exit Do
Loop           
Cells(500 + i, retu + 90).Select      
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                      
Sub HotNo_3Kanakuiti()
Dim kankaku_d, kankakukijyunn As Integer              
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)               
Cells(85, retu + 91).Select
kankakukijyunn = Cells(19, retu + 91) + 20
If kankaku_d <= 3 Then
Cells(kankakukijyunn, retu + 91).Select
End
End If
i = 0
Do Until Cells(85 + i, retu + 91) = ""     
   i = i + 1        
   If i = 500 Then Exit Do
Loop
Cells(85 + i, retu + 91).Select
start = MsgBox(kankaku_d & " 間隔はok?", vbYesNo)
If start = vbYes Then
  Cells(85 + i, retu + 91) = kankaku_d
  Cells(kankakukijyunn + 1, retu + 91).Select
Else
  End
End If
End Sub               
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                      
Sub HotNo_3KanakuWriter()
Dim kankaku_d As Integer              
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)
Cells(85, retu + 91).Select
If kankaku_d <= 3 Then
h = 0
Do Until Cells(20 + h, retu + 91) = ""
h = h + 1
Cells(19 + h, retu + 91).Select
If h = 50 Then Exit Do
Loop
End
End If
i = 0
Do Until Cells(85 + i, retu + 91) = ""        
  i = i + 1         
 If i = 500 Then Exit Do
Loop
Cells(85 + i, retu + 91).Select
start = MsgBox(kankaku_d & " 間隔はok?", vbYesNo)
If start = vbYes Then
  Cells(85 + i, retu + 91) = kankaku_d
Else
  End
End If
Cells(Cells(5, retu + 91) + 34, retu + 91).Select             
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー                                    
Sub HotNo_3KanakuWriter_moto()
Dim kankaku_d As Integer             
gyou = ActiveCell.Row
retu = ActiveCell.Column
kankaku_d = Cells(gyou, retu)
Cells(85, retu + 91).Select
i = 0
Do Until Cells(85 + i, retu + 91) = ""  
  i = i + 1            
 If i = 500 Then Exit Do
Loop
If kankaku_d > 3 Then
    Cells(85 + i, retu + 91) = kankaku_d
Else
    Cells(20, retu + 91).Select: End
End If
Cells(85 + i, retu + 91).Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー            

'土日を除いて日付を追加する。最後の日付の下で実行
Sub dayplus3()
Dim gyou As Integer             
Worksheets("原本").Select ’実行するシートを指定する。
gyou = ActiveCell.Row ’選択行を変数に入れる。
Cells(gyou - 1, 2).Copy Cells(gyou, 2)
Cells(gyou, 2) = Cells(gyou, 2) + 3 ’月曜日の日付を入れる。
’下の処理で火曜日~金曜日を入れる。
Selection.AutoFill Destination:=Range(Cells(gyou, 2), Cells(gyou + 4, 2)), Type:=xlFillDefault
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー