ムラゴン ホーム
２.N4プロパティ分析
Sub copytotal()
gyou = ActiveCell.Row
iti = Cells(gyou, 2)
kankaku_gk = Cells(gyou - 1, 4 + iti)
If kankaku_gk = "●" Then kankaku_gk = 0
Range(Cells(gyou, 4), Cells(gyou, 40)).Select
Selection.Copy
Sheets("結果まとめ").Select
Range("ms3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms12:ms30").Select
Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(40, 357) = kankaku_gk
i = 0
Cells(iti + 3, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(iti + 3, 356 - i) <> "" '間隔記入位置を決める
Cells(iti + 3, 356 - i).Select
i = i + 1
Loop
Cells(iti + 3, 357 - i) = kankaku_gk '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub copykiguu()
gyou = ActiveCell.Row
If gyou <= 3 Then End
If Cells(gyou, 4) = "" Then End
iti = Cells(gyou, 2) '奇遇タイプ
kankaku_kg = Cells(gyou - 1, 3 + iti) '間隔を把握する
If kankaku_kg = "●" Then kankaku_kg = 0
Range(Cells(gyou, 4), Cells(gyou, 19)).Select
Selection.Copy
Sheets("結果まとめ").Select
Range("ms46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms46:ms61").Select
Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(45, 357) = kankaku_kg
Cells(iti + 45, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(iti + 45, 356 - i) <> "" '間隔記入位置を決める
Cells(iti + 45, 356 - i).Select
i = i + 1
Loop
Cells(iti + 45, 357 - i) = kankaku_kg '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub copysb()
Dim sbiti As long
gyou = ActiveCell.Row
If gyou <= 4 Then End
If Cells(gyou, 168) = "" Then End
sbiti = Cells(gyou, 167)
kankaku_sb = Cells(gyou - 1, sbiti + 167)
If kankaku_sb = "●" Then kankaku_sb = 0
Range(Cells(gyou, 168), Cells(gyou, 183)).Select
Selection.Copy
Sheets("結果まとめ").Select
Range("ms65").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("ms65:ms80").Select
Selection.Replace What:="●", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Cells(64, 357) = kankaku_sb
i = 0
Cells(sbiti + 64, 357).Select '間隔記入位置原点
i = 0
Do Until Cells(sbiti + 64, 356 - i) <> "" '間隔記入位置を決める
Cells(sbiti + 64, 356 - i).Select
i = i + 1
Loop
Cells(sbiti + 64, 357 - i) = kankaku_sb '間隔記入する。
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 縦揃え()
Dim datas(300) As long
retu = ActiveCell.Column
gyou = ActiveCell.Row
j = 0
i = 0
Do Until retu - i = 2
If Cells(gyou, retu - i) <> "" Then
datas(i - j + 1) = Cells(gyou, retu - i)
End If
If retu = 1 Then Exit Do
i = i + 1: k = i
j = j + 1
Loop
For i = 1 To k
Cells(100, retu - i + 1) = datas(i)
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub color_set()
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 桁集計()
Call saikeisanoff
Sheets("千百分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
ActiveWindow.SmallScroll Down:=113
Range("Z130").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("千十分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z132").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("千一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z134").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("百十分析").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z136").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("百一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z138").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("十一分析 ").Select
Range("I4:J5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("桁分析").Select
Range("Z140").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Call saikeisanon
kaigot = 0
For k = 1 To 12 Step 2 '130 133
kaigot = kaigot + Cells(k + 129, 26)
Next k
If Cells(130, 26) <> kaigot / 6 Then MsgBox ("入力ミスがあります")
Range("Z130").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Boxx_Kensaku()
On Error GoTo errorcheck
'Static maeban
maeban = Cells(1, 1)
Range("B2:b1430").Select
bango = Application.InputBox("BOX番号入力して下さい", Default:=maeban)
maeban = bango
Cells(1435, 1) = maeban
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
Range(Cells(gyou, retu), Cells(gyou, retu)).Select
i = 0
Do Until Cells(gyou, 2 + i) = ""
i = i + 1
Range(Cells(gyou, 2 + i), Cells(gyou, 2 + i)).Select
If i = 40 Then Exit Do
Loop
Exit Sub
errorcheck:
MsgBox "エラー番号" & Err & ":" & Error(Err): End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 空行除去()
'飛び期間の空行を詰めて表示する。
Dim x As long, i As long, k As long, retu_1 As long, retu_2 As long
actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then '元データをコピーする。
Range("av5:bk1000").ClearContents
retu_1 = 28: retu_2 = 47
ElseIf actsheet = "合計" Then
Range("gw5:hl800").Select
Selection.ClearContents
retu_1 = 185: retu_2 = 204
Else
End
End If
saikeisanoff
For x = 1 To 16
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, retu_1 + x) <> "" Then
Cells(5 + i - k, retu_2 + x).Value = Cells(5 + i, retu_1 + x).Value
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 空行除去_2()
'飛び期間の空行を詰めて表示する。
Dim x As long, i As long, k As long, retu_1 As long, retu_2 As long
actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then '元データをコピーする。
Range("av5:bk800").ClearContents
retu_1 = 4: retu_2 = 47
ElseIf actsheet = "合計" Then
Range("gw5:hl800").Select
Selection.ClearContents
retu_1 = 185: retu_2 = 204
Else
End
End If
saikeisanoff
For x = 1 To 16
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, retu_1 + x) = "●" Then
Cells(5 + i - k, retu_2 + x).Value = Cells(5 + i, retu_1 + x).Value
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 空行除去整列()
Dim gokei_max As long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
actsheet = ActiveSheet.Name
If actsheet = "奇遇" Then
retu_2 = 47
frg = 48
ElseIf actsheet = "合計" Then
retu_2 = 204
frg = 205
Else
End
End If
start = MsgBox("整列開始しますか？", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(2, retu_2)
For i = 1 To 16
motosuu = Cells(2, i + retu_2)
Range(Cells(5, i + retu_2), Cells(5 + motosuu, i + retu_2)).Select '番号
Selection.Cut
Cells(5 + gokei_max - motosuu, i + retu_2).Select
ActiveSheet.Paste
Next i
Range(Cells(5, frg), Cells(gokei_max + 4, frg + 15)).Select
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 奇偶整列()
Dim kigu_max As long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long
If Cells(5, 48) = Empty Then End
start = MsgBox("整列開始しますか？", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
kigu_max = Cells(2, 47)
For i = 1 To 16
motosuu = Cells(2, i + 47)
Range(Cells(5, i + 47), Cells(5 + motosuu, i + 47)).Select '番号
Selection.Cut
Cells(5 + kigu_max - motosuu, i + 47).Select
ActiveSheet.Paste
Next i
Range(Cells(5, 48), Cells(gokei_max + 4, 63)).Select
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 合計空行除去()
'飛び期間の空行を詰めて表示する。
Dim x As long, i As long, k As long
Sheets("合計").Select
Range("cg5:dq800").ClearContents
saikeisanoff
For x = 1 To 36
i = 0: k = 0
Do Until Cells(5 + i, 2) = ""
If Cells(5 + i, 44 + x) <> "" Then
Cells(5 + i - k, 84 + x).Value = Cells(5 + i, 44 + x).Value
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 合計整列()
Dim gokei_max As long
Dim i As long, ii As long, j As long, jj As long, k, start As long
Sheets("合計").Select
If Cells(5, 110) = "" Then End
start = MsgBox("整列開始しますか？", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
gokei_max = Cells(1, 80)
For i = 1 To 35
motosuu = Cells(3, i + 85)
'If Cells(9, 110) = "" Then End
Range(Cells(5, i + 85), Cells(5 + motosuu, i + 85)).Select '番号
Selection.Cut
Cells(5 + gokei_max - motosuu, i + 85).Select
ActiveSheet.Paste
Range(Cells(5, 94), Cells(gokei_max + 4, 112)).Select
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 大小整列()
Dim daisyo_max As long
Dim i As long, ii As long, j As long, jj As long, k As long, start As long, motosuu As long
Sheets("合計").Select
If Cells(5, 211) = "" Then End
start = MsgBox("整列開始しますか？", vbYesNo)
If start = vbNo Then End
Call saikeisanoff '再計算を止めて計算を速くする
daisyo_max = Cells(1, 220)
For i = 1 To 16
motosuu = Cells(2, i + 204)
Range(Cells(5, i + 204), Cells(5 + motosuu, i + 204)).Select '番号
Selection.Cut
Cells(5 + daisyo_max - motosuu, i + 204).Select
ActiveSheet.Paste
Range(Cells(5, 205), Cells(daisyo_max + 4, 220)).Select
Next i
Call saikeisanon '再計算を起動させる
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub tobi_kikan_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 = 4001 Then Exit Do
i = i + 1
Loop
If i = 0 Then MsgBox "ﾃﾞｰﾀ等をﾁｪｯｸして下さい。": End
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 頭へ()
ActiveWindow.ScrollRow = 1
End Sub
Sub boxへ()
Sheets("box").Select
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Seiretu_peace()
Dim prodata(500)
Sheets("結果まとめ").Select
ActiveWorkbook.PrecisionAsDisplayed = False
saikeisanoff
retu_1 = ActiveCell.Column
gyou = ActiveCell.Row
Range("C62:Mr120").Select
Selection.ClearContents
Range("C3:mr120").Select
Selection.Copy
Range("C65").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = 1
Do Until Cells(gyou, retu_1 - i) <> ""
i = i + 1
If i > 500 Then Exit Do
Loop
Cells(gyou, retu_1 - i).Select
retu_2 = ActiveCell.Column
j = 0
Do Until Cells(gyou, retu_2 - j) = ""
Cells(gyou, retu_2 - j).Select
prodata(j) = Cells(gyou, retu_2 - j)
j = j + 1
If j > 500 Then Exit Do
Loop
For h = 0 To j
Cells(62, retu_1 - h) = prodata(h)
Next h
Range(Cells(62, 3), Cells(62, retu_1)).Select
Selection.Copy
Cells(gyou, 3).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(gyou, retu_1).Select
saikeisanon
ActiveWorkbook.PrecisionAsDisplayed = True
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー