Option Explicit
'
Public Const G_MSG_TIL As String = "L6L7"
Public Const L6_SHEET As String = "L6"
Public Const L7_SHEET As String = "L7"
Public Const L6T_SHEET As String = "L6T"
Public Const L7T_SHEET As String = "L7T"
' メイン処理
'
Sub Main()
Application.MacroOptions Macro:="Main", ShortcutKey:="j"
Dim wsL6 As Worksheet: Set wsL6 = Worksheets(L6_SHEET)
Dim wsL7 As Worksheet: Set wsL7 = Worksheets(L7_SHEET)
Dim wsL6T As Worksheet: Set wsL6T = Worksheets(L6T_SHEET)
Dim wsL7T As Worksheet: Set wsL7T = Worksheets(L7T_SHEET)
Dim iEndRowL6 As Long
Dim iEndRowL7 As Long
' -------------------------------
' 初期処理
' -------------------------------
iEndRowL6 = wsL6.Cells(Rows.Count, 2).End(xlUp).Row
iEndRowL7 = wsL7.Cells(Rows.Count, 2).End(xlUp).Row
' -------------------------------
' 主処理
' -------------------------------
Dim i As Long: i = 1
Dim j As Long: j = 3
Dim iPos As Long: iPos = 1
Dim iStaRowL6 As Long: iStaRowL6 = 2
'-- L6 -> L6T --------------------------------------
wsL6.Activate
For j = 1 To 43
wsL6T.Cells(1, j + 2) = j
wsL6T.Cells(1, j + 2).Interior.ColorIndex = 8
Next j
For i = iStaRowL6 To iEndRowL6
For j = 1 To 6
If j = 1 Then
wsL6T.Cells(i, 1) = wsL6.Cells(i, 2)
End If
iPos = Trim(wsL6.Cells(i, j + 2))
wsL6T.Cells(i, iPos + 2) = "〇"
If Is_Lucky_Num(L6_SHEET, iPos) = True Then
wsL6T.Cells(i, iPos + 2) = "★"
End If
Next j
Next i
Call Format_T(L6T_SHEET, iEndRowL6, 44)
'最終列をシャドウ開始列へ
wsL6T.Range(Cells(1, 45), Cells(iEndRowL6, 45)).Copy _
Destination:=Range(Cells(1, 2), Cells(iEndRowL6, 2))
'開始列をシャドウ終了列へ
wsL6T.Range(Cells(1, 3), Cells(iEndRowL6, 3)).Copy _
Destination:=Range(Cells(1, 46), Cells(iEndRowL6, 46))
' 背景色
wsL6T.Range(Cells(1, 2), Cells(iEndRowL6, 2)).Interior.ColorIndex = 16
wsL6T.Range(Cells(1, 46), Cells(iEndRowL6, 46)).Interior.ColorIndex = 16
'// 出現回数
Call GetSyutugenCnt_CountA(L6T_SHEET, 2, 3, iEndRowL6, 45)
'// 合計と偶数比率
Call GetSumAndKigu(L6T_SHEET, 2, 3, iEndRowL6, 45)
'-- L7 -> L7T --------------------------------------
wsL7.Activate
Dim iStaRowL7 As Long: iStaRowL7 = 2
For j = 1 To 37
wsL7T.Cells(1, j + 2) = j
wsL7T.Cells(1, j + 2).Interior.ColorIndex = 6
Next j
For i = iStaRowL7 To iEndRowL7
For j = 1 To 7
If j = 1 Then
wsL7T.Cells(i, 1) = wsL7.Cells(i, 2)
End If
iPos = Trim(wsL7.Cells(i, j + 2))
wsL7T.Cells(i, iPos + 2) = "〇"
If Is_Lucky_Num(L7_SHEET, iPos) = True Then
wsL7T.Cells(i, iPos + 2) = "★"
End If
Next j
Next i
Call Format_T(L7T_SHEET, iEndRowL7, 38)
'最終列をシャドウ開始列へ
wsL7T.Range(Cells(1, 39), Cells(iEndRowL7, 39)).Copy _
Destination:=Range(Cells(1, 2), Cells(iEndRowL7, 2))
'開始列をシャドウ終了列へ
wsL7T.Range(Cells(1, 3), Cells(iEndRowL7, 3)).Copy _
Destination:=Range(Cells(1, 40), Cells(iEndRowL7, 40))
' 背景色
wsL7T.Range(Cells(1, 2), Cells(iEndRowL7, 2)).Interior.ColorIndex = 16
wsL7T.Range(Cells(1, 40), Cells(iEndRowL7, 40)).Interior.ColorIndex = 16
'// 出現回数
Call GetSyutugenCnt_CountA(L7T_SHEET, 2, 3, iEndRowL7, 39)
'// 合計と偶数比率
Call GetSumAndKigu(L7T_SHEET, 2, 3, iEndRowL7, 39)
'
' -------------------------------
' 終了処理
' -------------------------------
wsL6.Activate
Dim sMsg As String
sMsg = "処理終了" & vbCrLf & _
" L6 " & vbTab & iEndRowL6 & " 件" & vbCrLf & _
" L7 " & vbTab & iEndRowL7 & " 件"
MsgBox sMsg, , G_MSG_TIL
Exit Sub
SManError:
MsgBox "XXXXX ", vbExclamation
End Sub
'
' 合計値と奇数偶数比率
Function GetSumAndKigu(SHEET As String, _
iStaRow As Long, iStaCol As Long, _
iEndRow As Long, iEndCol As Long) As Boolean
Dim ws As Worksheet: Set ws = Worksheets(SHEET)
Dim i As Long
Dim j As Long
Dim iSum As Long
Dim iGuCnt As Double
GetSumAndKigu = False
'//
ws.Cells(1, iEndCol + 2) = "合計"
ws.Cells(1, iEndCol + 3) = "偶比%"
With ws.Range(Cells(1, iEndCol + 2), Cells(1, iEndCol + 3))
.ColumnWidth = 6
End With
'//
For i = iStaRow To iEndRow
iSum = 0: iGuCnt = 0
For j = iStaCol To iEndCol
'// 合計
If ws.Cells(i, j) <> "" Then
iSum = iSum + j - 2
'// 偶数件数
If j Mod 2 = 0 Then
iGuCnt = iGuCnt + 1
End If
End If
'Debug.Print iKensu
Next j
'// 合計セット
ws.Cells(i, iEndCol + 2) = iSum
'// 比率セット
If SHEET = L6T_SHEET Then
ws.Cells(i, iEndCol + 3) = Format(iGuCnt / 6 * 100, "0")
End If
If SHEET = L7T_SHEET Then
ws.Cells(i, iEndCol + 3) = Format(iGuCnt / 7 * 100, "0")
End If
Next i
'// 戻値
GetSumAndKigu = True
End Function
'
' 出現件数
Function GetSyutugenCnt_CountA(SHEET As String, _
iStaRow As Long, iStaCol As Long, _
iEndRow As Long, iEndCol As Long) As Boolean
Dim ws As Worksheet: Set ws = Worksheets(SHEET)
Dim j As Long
GetSyutugenCnt_CountA = False
On Error Resume Next
'//
With ws.Range(Cells(iEndRow + 1, iStaCol), Cells(iEndRow + 1, iEndCol))
' 罫線
.Borders.LineStyle(xlEdgeTop) = xlDashDotDot
.Borders(xlEdgeTop).Weight = xlMedium
.Borders.LineStyle(xlEdgeBottom) = xlDashDotDot
.Borders(xlEdgeBottom).Weight = xlMedium
End With
For j = iStaCol To iEndCol
ws.Cells(iEndRow + 1, j) = WorksheetFunction.COUNTA( _
ws.Range(Cells(j, iStaRow), _
ws.Cells(j, iEndRow)))
'Debug.Print iKensu
Next j
'// 戻値
GetSyutugenCnt_CountA = True
End Function
'
' 行スクロール解放し固定する
Function FreezePanes(SHEET As String, iRow As Integer, iCol As Integer) As Boolean
Dim ws As Worksheet: Set ws = Worksheets(SHEET)
With ActiveWindow
If .FreezePanes = True Then
.FreezePanes = False
End If
ws.Range(Cells(iRow, iCol), Cells(iRow, iCol)).Select
.FreezePanes = True
End With
End Function
' 書式を設定する
Public Function Format_T(SHEET As String, iEndRow As Long, iEndCol As Long) As Boolean
Dim ws As Worksheet: Set ws = Worksheets(SHEET)
Dim bRC As Boolean
ws.Activate
'クリヤー
'With Worksheets(M_SHEET)
' .Cells.Clear
'End With
ActiveWindow.Zoom = 100 ' 表示倍率を設定する
ActiveWindow.DisplayGridlines = False ' 目盛線を非表示
ws.Columns.AutoFit
' 罫線クリア
ws.Cells.Borders.LineStyle = xlLineStyleNone
With ws.Range(Cells(1, 3), Cells(iEndRow, iEndCol + 1))
.Rows.RowHeight = 13.5
.ColumnWidth = 2.5
' セルの文字
.Rows.AutoFit
'.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
' 罫線
.Borders.LineStyle = xlDot
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlHairline
.Borders(xlEdgeRight).Weight = xlHairline
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeTop).ColorIndex = 15
.Borders(xlEdgeLeft).ColorIndex = 15
.Borders(xlEdgeRight).ColorIndex = 15
.Borders(xlEdgeBottom).ColorIndex = 15
End With
' フォント
With Worksheets(SHEET).Cells.Font
.Name = "Meiryo UI"
.Size = 11
.ColorIndex = 16
End With
' 枠の固定(行・列)★
bRC = FreezePanes(SHEET, 2, 3)
' カーソル位置を設定する
ws.Activate
ws.Cells(3, 3).Select
'.Interior.ColorIndex = G_CLR_YEW
' // 戻値
Format_T = True
End Function
'
' My_Lucky_Numの判定
Public Function Is_Lucky_Num(SHEET As String, iNum As Long) As Boolean
Is_Lucky_Num = True
' // My_Lucky_Num
If SHEET = L6_SHEET Then
Select Case iNum
Case 21, 2, 29, 30, 42
Is_Lucky_Num = True
Case Else
Is_Lucky_Num = False
End Select
End If
' // My_Lucky_Num
If SHEET = L7_SHEET Then
Select Case iNum
Case 21, 2, 29, 30, 35
Is_Lucky_Num = True
Case Else
Is_Lucky_Num = False
End Select
End If
End Function
'
' 入力件数を受取り、確認画面を表示する
Public Function IsSeteiCheck(ws As Worksheet, iCnt As Integer) As Boolean
Dim iRC As Integer
Dim sMsg As String
IsSeteiCheck = False ' 初期値
sMsg = ""
'// 入力ファイルの保管フォルダー
sGFdr = Trim(ws.Cells(L_GYO_FDR, L_RTS_FDR))
If sGFdr <> "" Then
'// 指定ありでフォルダー存在チェック
If IsExistsFdr(ThisWorkbook.Path & "\" & sGFdr) = False Then
MsgBox sGFdr & " フォルダなし " & vbCrLf & sMsg, vbExclamation, G_MSG_TIL
Exit Function
End If
End If
sMsg = " 場所 " & vbTab & ThisWorkbook.Path & _
" BOOK : " & vbTab & ThisWorkbook.Name & vbCrLf & _
" SHEET : " & vbTab & L_SHEET & vbCrLf & _
" " & vbCrLf & _
" フォルダ : " & sGFdr & vbCrLf & _
" Entry件数: " & vbTab & iCnt
' 処理リストに件数ありの場合
If iCnt <> 0 Then
'// 確認メッセージを表示
sMsg = "処理開始 " & vbCrLf & sMsg
If MsgBox(sMsg, vbYesNo + vbInformation, G_MSG_TIL) = vbYes Then
IsSeteiCheck = True
Else
MsgBox "処理中止 " & vbCrLf & sMsg, vbExclamation, G_MSG_TIL
End If
Else
MsgBox "** NOT Entry ** " & vbCrLf & sMsg, vbExclamation, G_MSG_TIL
End If
End Function
'
' シートの存在確認
Public Function IsExistsSheet(ByVal ShName As String) As Boolean
Dim ws As Variant
For Each ws In Sheets
If LCase(ws.Name) = LCase(ShName) Then
IsExistsSheet = True ' 存在する
Exit Function
End If
Next
' // 戻値
IsExistsSheet = False
End Function
