Option Explicit
Public Const G_APLNAME As String = "実行スケジュールマン"
Public Const S_DGYO_S As Integer = 15
Public Const S_RTS_S As Integer = 3 'データの開始列
Public Const S_RTS_A1 As String = "C" 'ソース
Public Const WK_DGYO_S As Integer = 5 '出力結果の開始行
Public Const T_GYO_S As Integer = 5 '出力表の値の開始行
Public Const GLAY As Integer = 15 'グレイ
'シート
Public Const W_SHEET As String = "WK"
Public Const T_SHEET As String = "RES"
Public Const N_SHEET As String = "設定"
Public Const R_SHEET As String = "RES"
Public Const A_SHEET As String = "全チーム"
'設定
Public Const N_RTS_S As Integer = 4 ' テーブル開始列
'ソース 凡例
Public Const H_RTS_S As Integer = 15 ' 凡例開始列
Public Const H_SRH_LIMIT As Integer = 8
Public G_DGYO_S As Integer
Public G_S_BOOK As String
Public G_S_SHEET As String
Public G_TUKI As String
Public G_TUKI_YYYY As String
Public G_TUKI_MM As String
Public G_H_GYO_S As Integer
Sub Main()
Application.MacroOptions Macro:="Main", ShortcutKey:="j"
Dim wsN As Worksheet: Set wsN = Worksheets(N_SHEET)
Dim wsW As Worksheet: Set wsW = Worksheets(W_SHEET)
Dim wsT As Worksheet: Set wsT = Worksheets(T_SHEET)
Dim I As Integer
Dim iCnt As Integer
Dim iGyoNoCnt As Integer
Dim iCntUNQJob As Integer
Dim iGYO_LstNo As Integer
Dim iRTS_LstDay As Integer
Dim l As Integer
Dim arr() As String
Dim tmp() As String
Dim WKCALarr() As String
'2023.12.16
Dim iCpyCntJ As Long
Dim iResCntJ As Integer
Dim iResCntT As Integer
Dim iResCntR As Integer
Dim bRC As Boolean
Dim sMsg As String
Dim iResCnt As Integer
Dim sDate As String
Dim sDay As String
'2023.12.16
Dim iResTCnt As Long
' -------------------------------
' 初期処理
' -------------------------------
bRC = IsSeteiCheck()
If bRC = False Then
Exit Sub
End If
' 2023.12.15
'ウインドウ枠の固定
bRC = FreezePanes("RES", 5, 3)
bRC = FreezePanes("RES縦", 5, 11)
Dim wsS As Worksheet: Set wsS = Worksheets(G_S_SHEET)
Worksheets(G_S_SHEET).Activate
'調査範囲(開始行、開始列)で指定文字を行方向へ検索して
'行番号を求めた値を調査範囲の最大行番号とする
iGYO_LstNo = GetGYO_LstNo(wsS, G_DGYO_S, 2, "計")
Debug.Print iGYO_LstNo
If iGYO_LstNo = 0 Then
MsgBox "** ERRR ** iGYO_LstNo= " & iGYO_LstNo
Exit Sub
End If
'調査範囲(開始列、開始行)で指定文字を列方向へ検索して
'列番号を求めた値を調査範囲の最大列番号とする
iRTS_LstDay = GetRTS_LstDay(wsS, S_RTS_S, 13, "")
Debug.Print iRTS_LstDay
If iRTS_LstDay = 0 Then
MsgBox "** ERRR ** iRTS_LstDay= " & iRTS_LstDay
Exit Sub
End If
' -------------------------------
' 主処理
' -------------------------------
Application.ScreenUpdating = False ' 描画を停止する
'調査シートからカレンダー内容を配列へ保存
WKCALarr() = GetCalenderContents(wsS, _
iGYO_LstNo, _
iRTS_LstDay)
'WKシートを編集する
wsW.Activate
iGyoNoCnt = WK_Create(wsW, _
iGYO_LstNo, _
iRTS_LstDay, _
WKCALarr())
iCntUNQJob = WK_SortAndUNQJob(wsW, _
WK_DGYO_S, _
UBound(WKCALarr()))
Debug.Print " iGyoNoCnt= " & iGyoNoCnt & " iCntUNQJob= " & iCntUNQJob
'結果シートへ保存する
iCpyCntJ = Copy_WK_TO_RES(WK_DGYO_S, _
iCntUNQJob, _
WKCALarr())
iResCntT = RES_JOB_Calender(wsT, _
wsW, _
WK_DGYO_S, _
iCntUNQJob, _
WKCALarr())
'結果シートをチーム、JOBの順でデータを昇順に並べ替える
iResCntR = ResSettingJobSort(T_SHEET, _
T_GYO_S, _
T_GYO_S + iCntUNQJob - 1, _
"A", "AG", _
"A", "B")
Dim iACnt As Integer
Dim iRCnt As Integer
bRC = GetJobAttention(iACnt, iRCnt)
If bRC = False Then
sMsg = "注目項目のセットエラー"
MsgBox sMsg, vbInformation, G_APLNAME
End If
bRC = SetJobAttentionColor(iRCnt)
If bRC = False Then
sMsg = "注目項目の強調表示エラー"
MsgBox sMsg, vbInformation, G_APLNAME
End If
' -------------------------------
' 後処理
' -------------------------------
Application.ScreenUpdating = True ' 描画を再開する
iResTCnt = RESTATE_FromWK("RES縦", 5)
'2023.12.16
'印刷設定
bRC = PrintSetup("RES", "A", 2, "AI", iCpyCntJ, "A3", "横")
bRC = PrintSetup("RES縦", "B", 2, "V", iResTCnt + 4, "A3", "横")
If BookCopyMultiSheeet("RES", "RES縦") = False Then
Exit Sub
End If
sMsg = G_S_SHEET & " 分析シート " & G_S_SHEET & vbCrLf & _
"検索範囲 " & vbCrLf & _
" 縦 " & G_DGYO_S & " 行 ～" & " 終了 " & iGYO_LstNo & " 行 " & _
vbCrLf & _
" 横 " & 3 & " 列 ～" & iRTS_LstDay & " 列 " & vbCrLf & _
vbCrLf & _
" 年.月" & G_TUKI & vbCrLf & _
vbCrLf & _
"中間 " & iCpyCntJ & " 件 " & iGyoNoCnt & " 件" & vbCrLf & _
vbCrLf & _
" 実施JOB回数（取得/全体） " & " JOB数: " & iResCntT & " / " & iGyoNoCnt & _
vbCrLf & _
" 実施JOB件数 " & " JOB数: " & iCntUNQJob & " ソート行数 " & iResCntR & vbCrLf & _
"" & vbCrLf & _
" 強調表示項目の処理" & vbCrLf & _
" RESシート 件数:" & iRCnt & " 全チームシート 件数: " & iACnt
MsgBox sMsg, vbInformation, G_APLNAME
End Sub
'2023.12.16
Public Function PrintSetup(SHName As String, _
S_col As String, S_row As Long, _
E_col As String, E_row As Long, _
sSize As String, sHoukou As String) As Boolean
PrintSetup = False
If sSize = "A4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "A3" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "B4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
Exit Function
End If
End If
End If
With Sheets(SHName).PageSetup
' 範囲
.PrintArea = S_col & S_row & ":" & E_col & E_row + 3
'用紙サイズと方向
.Orientation = xlPortrait
.PaperSize = xlPaperA4
' 余白
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
' 中央
.CenterHorizontally = True 'CenterVertically
' 向き
.Orientation = xlLandscape ' xlPortrait
' ズーム(すべての列を1ページ)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
'ヘッダーとフッター
.CenterHeader = "&A"
.RightHeader = "&D"
.CenterFooter = "&P" & "/" & "&N"
End With
PrintSetup = True
End Function
'2023.12.15
'ウインドウ枠の固定
Function FreezePanes(ShName1 As String, iGYO As Integer, iRTU As Integer) As Boolean
Worksheets(ShName1).Activate
Cells(iGYO, iRTU).Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
FreezePanes = True
End Function
' 外部ブックとして保存
Public Function BookCopyMultiSheeet(ShName1 As String, ShName2 As String) As Boolean
Dim wb As Workbook
Dim sFileName As String
Dim sFileNameFull As String
Dim sMsg As String
sFileName = "結果_" & G_S_SHEET & "_" & G_TUKI_YYYY & G_TUKI_MM & Format(Now, "yymmddhhnn") & ".xlsx"
sFileNameFull = ThisWorkbook.Path & "\" & sFileName
If Dir(sFileNameFull) <> "" Then
sMsg = sFileName & vbCrLf & "が存在します"
MsgBox sMsg, vbInformation, G_APLNAME
BookCopyMultiSheeet = False
Exit Function
End If
Sheets(Array(ShName1, ShName2)).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs Filename:=sFileNameFull
wb.Close
Application.DisplayAlerts = True
BookCopyMultiSheeet = True
End Function
Public Function IsSeteiCheck() As Boolean
IsSeteiCheck = False
Dim wsN As Worksheet: Set wsN = Worksheets(N_SHEET)
Dim sMsg As String
Dim iRC As Integer
G_S_BOOK = sGetSettingValue(wsN, 2, 4)
G_S_SHEET = sGetSettingValue(wsN, 3, 4) ' 設定 分析シート
G_DGYO_S = iGetSettingValue(wsN, 4, 4) ' 設定 分析凡例開始行
G_H_GYO_S = sGetSettingValue(wsN, 5, 4) ' 設定 分析開始行
G_TUKI = sGetSettingValue(wsN, 6, 4) ' 設定 年月
'シート存在チェック
If IsExistsSheet(G_S_SHEET) = False Then
MsgBox "設定 シートなし " & G_S_SHEET, vbCritical, G_APLNAME
Exit Function
End If
'年月 チェック
If IsYYYYMM(G_TUKI) = False Then
Exit Function
End If
'分析開始行 チェック
If IsGyoNo(G_DGYO_S) = False Then
MsgBox "分析開始行誤 " & G_DGYO_S, vbCritical, G_APLNAME
Exit Function
End If
' 設定チェック
sMsg = " 分析シート : " & G_S_SHEET & vbCrLf & _
" 凡例開始行 : " & G_H_GYO_S & vbCrLf & _
" 値開始行 : " & G_DGYO_S & vbCrLf & _
" 年月(yyyy/mm) : " & G_TUKI
iRC = MsgBox(sMsg, vbYesNo + vbQuestion, G_APLNAME)
If iRC <> vbYes Then
MsgBox "処理を中止しました", vbExclamation, G_APLNAME
Exit Function
End If
'凡例開始行 チェック
If IsGyoNo(G_H_GYO_S) = False Then
MsgBox "凡例開始行誤 " & G_H_GYO_S, vbCritical, G_APLNAME
Exit Function
End If
IsSeteiCheck = True
End Function
Public Function IsGyoNo(ByVal G_DGYO_S As String)
Dim I As Long
Dim Buf As Variant '配列を指定
IsGyoNo = False
If IsNumeric(G_DGYO_S) = False Then
MsgBox "設定 分析開始行 " & G_DGYO_S, vbCritical, G_APLNAME
Exit Function
End If
IsGyoNo = True
End Function
' 年月チェック
Public Function IsYYYYMM(ByVal G_TUKI As String)
Dim I As Long
Dim Buf As Variant '配列を指定
Dim sYYYY As String
Dim sMM As String
IsYYYYMM = False
Buf = Split(G_TUKI, "/") '区切りで分割
For I = 0 To UBound(Buf) '配列に分割して格納したデータを繰返。
Debug.Print Buf(I)
Next I
Debug.Print UBound(Buf)
If UBound(Buf) <> 1 Then
MsgBox "設定 年月:形式エラー " & G_TUKI, vbCritical, G_APLNAME
Exit Function
End If
sYYYY = Buf(0)
sMM = Buf(1)
If IsNumeric(sYYYY) = False Then
MsgBox "設定 年月:年 " & sYYYY, vbCritical, G_APLNAME
Exit Function
End If
If IsNumeric(sMM) = False Then
MsgBox "設定 年月:月 " & sMM, vbCritical, G_APLNAME
Exit Function
Else
If sMM < 1 Or sMM > 12 Then
MsgBox " 年月:月範囲 " & sMM, vbCritical, G_APLNAME
Exit Function
End If
End If
G_TUKI_YYYY = sYYYY
G_TUKI_MM = sMM
IsYYYYMM = True
End Function
' Sheets に指定した名前のシートの存在確認
Public Function IsExistsSheet(ByVal SHName As String)
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
' カレンダー日の順に並替
Function RESTATE_FromWK(sh As String, _
iGYOS As Integer) As Integer
Dim iGYOE As Integer
Dim iSortCnt As Integer
Dim bRC As Boolean
RESTATE_FromWK = 0
With Worksheets(sh)
.Cells.Clear
End With
Sheets("WK").Select
Cells.Select
Selection.Copy
'
Worksheets(sh).Activate
Sheets(sh).Select
Sheets(sh).Cells(1, 1).Select
ActiveSheet.Paste
'
Range("C5:C5").Select
Range(Selection, Selection.End(xlDown)).Select
iGYOE = Selection.End(xlDown).Row
'
Application.CutCopyMode = False
ActiveWorkbook.Worksheets(sh). _
Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range("C" & iGYOS, "C" & iGYOE), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range("D" & iGYOS, "D" & iGYOE), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(sh).Sort
.SetRange Range("B" & iGYOS, "J" & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
iSortCnt = iGYOE - iGYOS + 1
Sheets(sh).Cells(iGYOS - 1, 2).Value = "曜"
Sheets(sh).Cells(iGYOS - 1, 3).Value = "日"
Sheets(sh).Cells(iGYOS - 1, 4).Value = "順"
Sheets(sh).Cells(iGYOS - 1, 5).Value = "JOB名"
Sheets(sh).Cells(iGYOS - 1, 6).Value = "夜"
Sheets(sh).Cells(iGYOS - 1, 7).Value = "回目"
Sheets(sh).Cells(iGYOS - 1, 8).Value = "Step数"
Sheets(sh).Cells(iGYOS - 1, 9).Value = "File数"
Sheets(sh).Cells(iGYOS - 1, 10).Value = "周期"
Sheets(sh).Cells(iGYOS - 1, 11).Value = "業務"
Sheets(sh).Cells(iGYOS - 1, 12).Value = "時刻"
Sheets(sh).Cells(iGYOS - 1, 13).Value = "昼夜"
Sheets(sh).Cells(iGYOS - 1, 15).Value = "スケジュール日△業務コード"
Sheets(sh).Cells(iGYOS - 1, 16).Value = "→結果(1)業務ＣＤ"
Sheets(sh).Cells(iGYOS - 1, 17).Value = "→結果(2)実行予定"
Sheets(sh).Cells(iGYOS - 1, 18).Value = "→結果(3)曜日"
Sheets(sh).Cells(iGYOS - 1, 20).Value = "①②ジョブ名（UNIQ）"
Sheets(sh).Cells(iGYOS - 1, 21).Value = "→結果 業務ＣＤ"
Sheets(sh).Cells(iGYOS - 1, 22).Value = "→結果 開始時刻"
Sheets(sh).Cells(iGYOS - 2, 3).Value = G_TUKI
Sheets(sh).Cells(iGYOS - 2, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 3, 3).Value = G_S_SHEET
Sheets(sh).Cells(iGYOS - 3, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 1, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 2, 7).Value = iSortCnt
Sheets(sh).Cells(iGYOS - 1, 15).ColumnWidth = 25
Sheets(sh).Cells(iGYOS - 1, 16).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 17).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 18).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 20).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 21).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 22).ColumnWidth = 20
'罫線③ 2023.12.01
With Sheets(sh).Range(Cells(5, 15), Cells(iGYOE, 18))
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'高さ
Rows("2:4").RowHeight = 25
Sheets(sh).Cells(1, 15) = "カレンダ日別の業務オンライン照会結果"
With Sheets(sh).Range("o" & 2, "V" & 2)
.Interior.ColorIndex = 3
.Font.Bold = True
End With
' 2023.12.01
Sheets(sh).Cells(2, 15) = "機械化調査（mac施順①→②→③"
Sheets(sh).Cells(3, 15) = "③稼働日の照合"
Sheets(sh).Cells(3, 21) = "①業務CD取得"
Sheets(sh).Cells(3, 22) = "②稼働時刻取得"
Sheets(sh).Cells(3, 15).WrapText = True
Sheets(sh).Cells(3, 21).WrapText = True
Sheets(sh).Cells(3, 22).WrapText = True
'フィルター設定
Sheets(sh).Rows("4:4").Select
Selection.AutoFilter
' サマリー件数を求める
bRC = Kensu("RES縦", iSortCnt)
RESTATE_FromWK = iSortCnt
End Function
'2023.12.01
Function Kensu(sh As String, iSortCnt As Integer) As Boolean
Kensu = False
'回目
Range("I7:I7").Select
Sheets(sh).Cells(3, 7).FormulaR1C1 = "=SUBTOTAL(103,R[2]C:R[" & iSortCnt + 1 & "]C)"
'Step数
Sheets(sh).Cells(3, 8).FormulaR1C1 = "=SUBTOTAL(109,R[2]C:R[" & iSortCnt + 1 & "]C)"
'File数
Sheets(sh).Cells(3, 9).FormulaR1C1 = "=SUM(R[2]C:R[" & iSortCnt + 1 & "]C)"
'JOB(重複除外)
Sheets(sh).Cells(3, 20).FormulaR1C1 = "=COUNTA(R[2]C:R[" & iSortCnt + 1 & "]C)"
Kensu = True
End Function
'
'指定範囲をキーを指定してデータソートする
Function ResSettingJobSort(sh As String, _
iGYOS As Integer, _
iGYOE As Integer, _
sRTSS As String, _
sRTSE As String, _
sKey1 As String, _
sKey2 As String) As Integer
Range(sRTSS & iGYOS, sRTSE & iGYOE).Select
ActiveWorkbook.Worksheets(sh).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range(sKey1 & iGYOS, sKey1 & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(sh).Sort.SortFields.Add Key _
:=Range(sKey2 & iGYOS, sKey2 & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(sh).Sort
.SetRange Range(sRTSS & iGYOS, sRTSE & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ResSettingJobSort = iGYOE - iGYOS + 1
End Function
'
Function WK_Create(wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const W_GYO_H As Integer = 4
Dim I As Integer
Dim l As Integer
Dim tmp() As String
Dim bRC As Boolean
With Worksheets(W_SHEET)
.Cells.Clear
End With
'共通フォーマット設定
bRC = W_COMM_FORMAT(wsW, W_GYO_H)
l = WK_DGYO_S
For I = 0 To UBound(WKCALarr())
'Debug.Print WKCALarr(i)
tmp = Split(WKCALarr(I), ":")
wsW.Cells(l, 3) = tmp(0) ' 日
wsW.Cells(l, 4) = tmp(1) ' 日内の順番
wsW.Cells(l, 5) = tmp(2) ' JOB
wsW.Cells(l, 6) = tmp(3) ' 回目
wsW.Cells(l, 7) = tmp(4) ' 日・夜
wsW.Cells(l, 8) = tmp(5) ' ステップ数
wsW.Cells(l, 9) = tmp(6) ' ファイル数
wsW.Cells(l, 10) = tmp(7) ' 周期
On Error Resume Next
Dim sDate
sDate = G_TUKI & "/" & Trim(wsW.Cells(l, 3))
wsW.Cells(l, 2) = WeekdayName(Weekday(sDate), True)
' 背景色
wsW.Cells(l, 3).Interior.Color = tmp(8)
wsW.Cells(l, 4).Interior.Color = tmp(8)
wsW.Cells(l, 5).Interior.Color = tmp(8)
wsW.Cells(l, 6).Interior.Color = tmp(8)
wsW.Cells(l, 7).Interior.Color = tmp(8)
wsW.Cells(l, 8).Interior.Color = tmp(8)
wsW.Cells(l, 9).Interior.Color = tmp(8)
wsW.Cells(l, 10).Interior.Color = tmp(8)
l = l + 1
Next I
' 罫線
With wsW.Range("C" & WK_DGYO_S, "J" & l - 1)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'ソート
Range("B" & WK_DGYO_S, "J" & l - 1).Select
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Clear
'ソートキー1
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add Key _
:=Range("C" & WK_DGYO_S, "C" & l - 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
'ソートキー2
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add Key _
:=Range("D" & WK_DGYO_S, "D" & l - 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
'ソート
With ActiveWorkbook.Worksheets(W_SHEET).Sort
.SetRange Range("B" & WK_DGYO_S, "J" & l - 1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
WK_Create = l - WK_DGYO_S
End Function
'
Function W_COMM_FORMAT(wsW As Worksheet, _
W_GYO_H As Integer) As Boolean
W_COMM_FORMAT = False
' フォント
With Worksheets(W_SHEET).Cells.Font
.Name = "Meiryo UI"
.Size = 11
End With
' 列の幅
wsW.Range("A" & W_GYO_H).Cells.ColumnWidth = 2
wsW.Range("B" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("C" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("D" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("E" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("F" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("G" & W_GYO_H).Cells.ColumnWidth = 14
wsW.Range("H" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("I" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("J" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("K" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("L" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("M" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("N" & W_GYO_H).Cells.ColumnWidth = 1
wsW.Range("O" & W_GYO_H).Cells.ColumnWidth = 20
wsW.Range("P" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("Q" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("R" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("S" & W_GYO_H).Cells.ColumnWidth = 1
wsW.Range("L" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("M" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("N" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("T" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("U" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("V" & W_GYO_H).Cells.ColumnWidth = 8
'書式
Columns("C:D").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("F:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
W_COMM_FORMAT = True
End Function
'
Function T_COMM_FORMAT(wsT As Worksheet, _
T_GYO_H As Integer) As Boolean
T_COMM_FORMAT = False
' フォント
With Worksheets(T_SHEET).Cells.Font
.Name = "Meiryo UI"
.Size = 11
End With
'書式
Columns("C:AG").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ColumnWidth = 5
End With
Columns("F:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
T_COMM_FORMAT = True
End Function
'
Function Copy_WK_TO_RES(iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const W_RTS_S_A1 As String = "T" 'コピー元のの開始列
Const T_RTS_S_A1 As String = "B" '出力表の値の開始列
Const T_GYO_S As Integer = 5 '出力表の値の開始行
Dim wsW As Worksheet: Set wsW = Worksheets(W_SHEET)
Dim wsT As Worksheet: Set wsT = Worksheets(T_SHEET)
Dim iGYOE As Integer
Copy_WK_TO_RES = 0
iGYOE = iGYOS + iCnt - 1
With Worksheets(T_SHEET)
.Cells.Clear
End With
Application.CutCopyMode = False
Worksheets(W_SHEET).Range(W_RTS_S_A1 & iGYOS, W_RTS_S_A1 & iGYOE).Select
Selection.Copy
Worksheets(T_SHEET).Activate
Sheets(T_SHEET).Select
Range(T_RTS_S_A1 & T_GYO_S).Select
ActiveSheet.Paste
Copy_WK_TO_RES = iCnt
End Function
'
Function RES_JOB_Calender(wsT As Worksheet, _
wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const S_GYO_S As Integer = 5 '入力データ開始行
Const W_GYO_S As Integer = 5 '入力データ開始行
Const W_GYO_DAY As Integer = 3 '入力データ開始列(日付)
Const W_RTS_JOB As Integer = 5 '入力データ開始列(JOB)
Const T_RTS_JOB As Integer = 2 '出力表の開始列(JOB)
Const T_RTS_DAY As Integer = 3 '出力表の開始列(日付)
Const T_GYO_S As Integer = 5 '出力表の値の開始行
Const T_RTS_S As Integer = 2 '出力表の値の開始列
Const E_RTS_DAY As Integer = 34 '日付の終了列
Dim iGYOE As Integer
Dim iLastCnt As Integer
Dim iResCnt As Integer
Dim j As Integer
Dim I As Integer
Dim iHDR1GYO As Integer
Dim iHDR2GYO As Integer
Dim iDayS As Integer
Dim iGyoTOT As Integer
Dim iDayNo As Integer
Dim s As Integer
Dim w As Integer
Dim t As Integer
Dim tGyo As Integer
Dim sCntMax As Integer
Dim tCntMax As Integer
Dim bRC As Boolean
RES_JOB_Calender = 0
iGYOE = iGYOS + iCnt - 1
iGyoTOT = T_GYO_S + iCnt
'共通フォーマット設定
bRC = T_COMM_FORMAT(wsT, 1)
' ----------------------------
' 表 ヘッダー タイトル
' ----------------------------
iHDR1GYO = T_RTS_DAY
iHDR2GYO = T_RTS_DAY + 1
wsT.Range(Cells(iHDR1GYO, W_GYO_DAY), Cells(iHDR1GYO, E_RTS_DAY)). _
Borders.LineStyle = xlContinuous
Range("C3:AG3").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
iDayS = T_RTS_DAY
wsT.Cells(iHDR1GYO, iDayS - 1).Value = "JOB名"
wsT.Cells(iHDR2GYO, iDayS - 1).Value = ""
iDayNo = 1
For I = iDayS To iDayS + 31 Step 1
wsT.Cells(iHDR2GYO, I).Value = iDayNo
wsT.Cells(iHDR2GYO, I).Borders.LineStyle = xlContinuous
wsT.Cells(iHDR2GYO, I).HorizontalAlignment = xlLeft
wsT.Cells(iHDR2GYO, I).VerticalAlignment = xlCenter
iDayNo = iDayNo + 1
Next I
wsT.Range("C3").Value = G_TUKI
' ----------------------------
' 表 コンテンツ レイアウト
' ----------------------------
j = T_GYO_S
I = 3
wsT.Range(Cells(j, I), Cells(j + iCnt, I + 31)). _
Borders.LineStyle = xlContinuous
wsT.Range("C" & j, "AG" & iCnt + 5).HorizontalAlignment = xlCenter
wsT.Range("C" & j, "AG" & iCnt + 5).VerticalAlignment = xlCenter
' 横合計の計算値を挿入
' 縦の集計行
wsT.Range("AH" & iGYOS).Cells.ColumnWidth = 5
wsT.Range("AI" & iGYOS).Cells.ColumnWidth = 5
wsT.Cells(iHDR1GYO, 34).Value = "実行"
wsT.Cells(iHDR2GYO, 34).Value = "回数"
wsT.Cells(iHDR1GYO, 34).Interior.ColorIndex = GLAY
wsT.Cells(iHDR2GYO, 34).Interior.ColorIndex = GLAY
For I = T_GYO_S To iCnt + T_GYO_S Step 1
wsT.Range("AH" & I).Formula = _
"=COUNTIF($C" & I & ":" & "$AG" & I & ",""〇"")"
wsT.Range("AH" & I).Interior.ColorIndex = GLAY
Next I
'合計の合計
wsT.Range("AI" & I - 1).Formula = _
"=SUM($AH" & T_GYO_S & ":" & "$AH" & I - 1 & ")"
' 横の集計行
iDayS = T_RTS_DAY
wsT.Cells(iGyoTOT, iDayS - 1).Value = "JOB数"
wsT.Range(Cells(iGyoTOT, iDayS - 1), Cells(iGyoTOT, iDayS + 31)). _
Borders.LineStyle = xlContinuous
For I = iDayS To iDayS + 30 Step 1
wsT.Cells(iGyoTOT, I).FormulaR1C1 = _
"=COUNTIF(R[-" & iCnt + 1 & "]C" & ":" & "R[-1]C,""〇"")"
wsT.Cells(iGyoTOT, I).Interior.ColorIndex = GLAY
Next I
'合計の合計
wsT.Range("AG" & iGyoTOT + 1).Formula = _
"=SUM($C" & iGyoTOT & ":" & "$AG" & iGyoTOT & ")"
'フィルター設定
wsT.Rows("4:4").Select
Selection.AutoFilter
wsT.Cells(iHDR1GYO - 2, 1).Value = G_S_SHEET
wsT.Cells(iHDR1GYO, 1).Value = "チーム名"
' ----------------------------
' チーム名のセット
' ----------------------------
bRC = GetTeamNameAndFormat(wsW, wsT, iCnt)
' ----------------------------
' 個々の該当識別のセット
' ----------------------------
tGyo = T_GYO_S
sCntMax = UBound(WKCALarr()) + 1
tCntMax = iCnt
For w = W_GYO_S To sCntMax + W_GYO_S
For t = tGyo To tCntMax + T_GYO_S
If Trim(wsT.Cells(t, T_RTS_JOB).Value) = _
Trim(wsW.Cells(w, W_RTS_JOB).Value) Then
'出力表の開始列に入力日付の値を足した位置
j = T_RTS_S + wsW.Cells(w, W_GYO_DAY).Value
wsT.Cells(t, j).Value = "〇"
If InStr(1, wsW.Cells(w, W_GYO_DAY + 4).Value, "X") > 0 Then
wsT.Cells(t, j).Value = "〇→X"
End If
'出力表の検索開始行を更新する
tGyo = t
Exit For
End If
Next t
'Debug.Print "s=" & s
Next w
wsT.Cells(iGYOS - 3, 1).Value = "● " & G_S_SHEET
wsT.Cells(iGYOS - 3, 1).HorizontalAlignment = xlLeft
wsT.Cells(iGYOS - 3, 4).Value = "〇→X " & G_S_SHEET
wsT.Cells(iGYOS - 3, 4).HorizontalAlignment = xlLeft
wsT.Cells(iGYOS - 2, 1).Value = "担当T"
RES_JOB_Calender = wsT.Range("AG" & iGyoTOT + 1).Value
End Function
'
Function WK_SortAndUNQJob(wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer) As Integer
Dim iGYOE As Integer
Dim iLastCnt As Integer
Dim iResCnt As Integer
wsW.Range("K" & iGYOS).Cells.ColumnWidth = 2
iGYOE = iGYOS + iCnt
wsW.Activate
wsW.Range("B" & iGYOS, "J" & iGYOS).Select
wsW.Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Clear
' JOBの昇順（第1キー)
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add _
Key:=Range("E" & iGYOS, "E" & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
' 日付の昇順（第2キー)
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add _
Key:=Range("C" & iGYOS, "C" & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
' 並び替え
With ActiveWorkbook.Worksheets(W_SHEET).Sort
.SetRange Range("B" & iGYOS, "J" & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Debug.Print "JobAllCnt= " & iGYOE - iGYOS
'重複削除の為にJOB枠のコピー
wsW.Range("E" & iGYOS, "E" & iGYOS).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("T" & iGYOS).Select
ActiveSheet.Paste
' 重複削除を実行してJOB一覧を作成
wsW.Range("T" & iGYOS, "T" & iGYOS).Select
wsW.Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-102
Application.CutCopyMode = False
ActiveSheet.Range("$T$" & iGYOS, "$T$" & iGYOE).RemoveDuplicates _
Columns:=1, Header:=xlNo
' 重複削除の結果件数
On Error Resume Next
iResCnt = wsW.Range("T" & iGYOS).End(xlDown).Row
'罫線
With wsW.Range("T" & WK_DGYO_S, "V" & iResCnt)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
wsW.Range("K" & 1).Cells.ColumnWidth = 6
wsW.Range("L" & 1).Cells.ColumnWidth = 10
wsW.Range("M" & 1).Cells.ColumnWidth = 4
wsW.Range("O" & 1).Cells.ColumnWidth = 20
'設定シートから年月を取得
Dim wsQ As Worksheet
Set wsQ = Worksheets("設定")
wsW.Range("C3").Value = wsQ.Range("D6")
' JOB名と紐つく業務CDと時刻
Dim iV As Integer
For iV = iGYOS To iGYOE Step 1
'(K列) 業務コードの引当
wsW.Range("$K" & iV).Formula = "=VLOOKUP($E" & iV & ",$T:$U,2,false)"
'(L列) 稼働時刻の引当
wsW.Range("$L" & iV).Formula = "=TEXT(VLOOKUP($E" & iV & ",$T:$V,3,false)," & _
"""HH:MM:SS""" & ")"
'(M列) 昼夜識別記号
wsW.Range("$M" & iV).Formula = "=IF(OR($L" & iV & ">" & """#09:30:00""" & ", " & _
"$L" & iV & "<" & """#04:25:00""" & "), " & _
"""●""" & "," & """ """ & "" & ")"
'(O列) スケジュール日＋△＋業務コード
wsW.Range("$O" & iV).Formula = "=RIGHT(TEXT($C$3,""YYYYMM"")" & ",4)" & _
" & TEXT($C" & iV & "," & """00""" & ")" & _
" & " & """ """ & _
" & $K" & iV
Next
iResCnt = iResCnt - iGYOS + 1
WK_SortAndUNQJob = iResCnt
End Function
'
Function GetCalenderContents(wsS As Worksheet, _
iGYO_LstNo As Integer, _
iRTS_LstDay As Integer) As String()
Const S_RTS_NO_STA As Integer = 2 '
Dim I As Integer
Dim j As Integer
Dim k As Integer
Dim iCellMaxNo As Integer
Dim iCellMaxMaxNo As Integer
Dim arr() As String
Dim sCycle As String
Dim iOutFg As Integer
Dim arrLen As Long
Dim val As Variant
Dim ivalCnt As Integer
iCellMaxMaxNo = iGYO_LstNo * iRTS_LstDay
ReDim arr(0 To iCellMaxMaxNo)
j = 3
k = 0
For j = S_RTS_S To iRTS_LstDay Step 5
'Debug.Print "■G_DGYO_S=" & G_DGYO_S
For I = iGYO_LstNo To G_DGYO_S Step -1
iOutFg = 0
If InStr(wsS.Cells(I, j), "日次") > 0 Or _
InStr(wsS.Cells(I, j), "週次") > 0 Or _
InStr(wsS.Cells(I, j), "月次") > 0 Or _
InStr(wsS.Cells(I, j), "年次") > 0 Then
sCycle = wsS.Cells(I, j)
Else
If Trim(wsS.Cells(I, j)) <> "" Then
iOutFg = 1
End If
End If
If iOutFg = 1 Then
arr(k) = _
wsS.Cells(13, j) & ":" & _
wsS.Cells(I, 2) & ":" & _
wsS.Cells(I, j) & ":" & _
wsS.Cells(I, j + 1) & ":" & _
wsS.Cells(I, j + 2) & ":" & _
wsS.Cells(I, j + 3) & ":" & _
wsS.Cells(I, j + 4) & ":" & _
sCycle & ":" & _
wsS.Cells(I, j).Interior.Color
k = k + 1
End If
Next
Next
For Each val In arr
'Debug.Print val
If val = "" Then
ivalCnt = ivalCnt + 1
End If
Next
'
arrLen = UBound(arr) - ivalCnt
If arrLen < 0 Then
arrLen = 0
End If
ReDim Preserve arr(arrLen)
'ReDim Preserve arr(UBound(arr) - ivalCnt)
GetCalenderContents = arr()
End Function
' Noの値の最大行番号を求める
Function GetGYO_LstNo(wsS As Worksheet, _
I As Integer, _
S_RTS_NO As Integer, _
sSrhChar As String) As Integer
Const S_SRH_GYO_MAXCNT As Integer = 1000 '
Dim iCnt As Integer
iCnt = I
GetGYO_LstNo = 0
Do Until _
Trim(wsS.Cells(iCnt, S_RTS_NO).Value) = sSrhChar Or _
iCnt > S_SRH_GYO_MAXCNT
iCnt = iCnt + 1
Loop
GetGYO_LstNo = iCnt - 1
End Function
' 月末の値の最大列番号を求める
Function GetRTS_LstDay(wsS As Worksheet, _
j As Integer, _
S_GYO_DAY As Integer, _
sSrhChar As String) As Integer
Const S_SRH_RTS_MAXCNT As Integer = 500 '
GetRTS_LstDay = 0
Do Until _
Trim(wsS.Cells(S_GYO_DAY, j)) = sSrhChar Or _
j > S_SRH_RTS_MAXCNT
j = j + 5
Loop
GetRTS_LstDay = j - 1
End Function
' カラーコードを元にチーム名を取得する
Function GetTNameByColorCd(iColorCd As Long) As String
Dim wsS As Worksheet: Set wsS = Worksheets(G_S_SHEET)
Dim sName As String
Dim I As Integer
sName = ""
I = G_H_GYO_S
Do Until _
Trim(wsS.Cells(I, H_RTS_S)) = "" Or _
I > G_H_GYO_S + H_SRH_LIMIT
If wsS.Cells(I, H_RTS_S).Interior.Color = iColorCd Then
sName = wsS.Cells(I, H_RTS_S).Value
Exit Do
End If
I = I + 1
Loop
If I > G_H_GYO_S + H_SRH_LIMIT Then
MsgBox "XGetTNameByColorCd チーム最大検索数 " & H_SRH_LIMIT & " を超過"
End If
GetTNameByColorCd = sName
End Function
'
Function GetTeamNameAndFormat(wsW As Worksheet, wsT As Worksheet, iCnt As Integer) As Boolean
' ----------------------------
' チーム名のセット
' ----------------------------
Const T_RTS_Setting As Integer = 1 '出力表の開始列(設定)
Const T_RTS_JOB As Integer = 2 '出力表の開始列(JOB)
Dim tGyo As Integer
Dim t As Integer
tGyo = T_GYO_S
For t = T_GYO_S To iCnt + T_GYO_S
' 背景色
wsT.Cells(t, T_RTS_Setting).Interior.Color = _
wsT.Cells(t, T_RTS_JOB).Interior.Color
' 名前
wsT.Cells(t, T_RTS_Setting).Value = _
GetTNameByColorCd(wsT.Cells(t, 1).Interior.Color)
' 線
wsT.Cells(t, T_RTS_Setting).Borders.LineStyle = xlContinuous
Next t
End Function
'
Function iGetSettingValue(wsN As Worksheet, _
I As Integer, j As Integer) As Integer
Dim iValue As Integer
iValue = 0
iValue = Trim(wsN.Cells(I, j).Value)
iGetSettingValue = iValue
End Function
'
Function sGetSettingValue(wsN As Worksheet, _
I As Integer, j As Integer) As String
Dim sValue As String
sValue = ""
sValue = Trim(wsN.Cells(I, j).Value)
sGetSettingValue = sValue
End Function
' ============================================================
' = JOB単位に注意項目を求める
' ============================================================
Function GetJobAttention(ByRef iACnt, ByRef iRCnt) As Boolean
Const R_SRCH_LIMIT As Integer = 500 '検索上限値
Const R_RTS_RERUN As Integer = 37 '単純リラン不可 列番号
Const R_RTS_USEDB As Integer = 38 'DB使用 列番号
Const R_RTS_A_REFLINE As Integer = 39 '全シートの参照行
Const A_SRCH_LIMIT As Integer = 3600 '検索上限値
Const A_RTS_RERUN As Integer = 17 '全シート 単純リラン不可 列番号
Const A_RTS_USEDB As Integer = 117 '全シート DB使用 列番号
Dim wsR As Worksheet: Set wsR = Worksheets(R_SHEET)
Dim wsA As Worksheet: Set wsA = Worksheets(A_SHEET)
Dim iR_RTS_JOB As Integer
Dim iR_RTS_ReRun As Integer
Dim iR_RTS_UseDB As Integer
Dim iR As Integer
Dim iA_RTS_JOB As Integer
Dim iA_RTS_ReRun As Integer
Dim iA_RTS_UseDB As Integer
Dim iA As Integer
Dim sJobName As String
GetJobAttention = False
' - R -
iRCnt = 0: iACnt = 0
sJobName = ""
iR = 5: iR_RTS_JOB = 2
Do Until _
Trim(wsR.Cells(iR, iR_RTS_JOB)) = "" Or _
iR > R_SRCH_LIMIT
' - A -
iACnt = 0
sJobName = Trim(wsR.Cells(iR, iR_RTS_JOB))
iA = 8: iA_RTS_JOB = 5
Do Until _
Trim(wsA.Cells(iA, iA_RTS_JOB)) = "" Or _
iA > A_SRCH_LIMIT
If Trim(wsA.Cells(iA, iA_RTS_JOB)) = sJobName Then
'リラン可能
wsR.Cells(iR, R_RTS_RERUN) = Trim(wsA.Cells(iA, A_RTS_RERUN))
'DB使用
wsR.Cells(iR, R_RTS_USEDB) = Trim(wsA.Cells(iA, A_RTS_USEDB))
' 前シートの行数
wsR.Cells(iR, R_RTS_A_REFLINE) = iA
Exit Do
End If
iA = iA + 1
Loop
If iA > A_SRCH_LIMIT Then
MsgBox sJobName & A_SHEET & " 最大検索行を超えました" & iA
GetJobAttention = False
End If
iR = iR + 1
Loop
If iR > R_SRCH_LIMIT Then
MsgBox sJobName & R_SHEET & " 最大検索行を超えました" & iR
GetJobAttention = False
End If
'件数
iACnt = iA
iRCnt = iR
GetJobAttention = True
End Function
'
' ============================================================
' = 注意項目の強調表示をする
' ============================================================
Function SetJobAttentionColor(ByRef iRCnt) As Boolean
Const CHAR_COLOR As Integer = 7 '文字色（ピンク）
Const BACK_COLOR As Integer = 6 '背景色（黄色）
Const R_RTS_RERUN As Integer = 37 '単純リラン不可 列番号
Const R_RTS_USEDB As Integer = 38 'DB使用 列番号
Const R_SRCH_LIMIT As Integer = 500 '検索上限値
Dim wsR As Worksheet: Set wsR = Worksheets(R_SHEET)
Dim iR_RTS_JOB As Integer
Dim iR_RTS_ReRun As Integer
Dim iR_RTS_UseDB As Integer
Dim iR_GYO As Integer
Dim iD_RTS_DAY As Integer
SetJobAttentionColor = False
'凡例
wsR.Cells(2, 9).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 9) = "〇"
wsR.Cells(2, 10) = ":DB使用"
wsR.Cells(2, 10).HorizontalAlignment = xlLeft
wsR.Cells(2, 14).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 14).Font.Bold = True
wsR.Cells(2, 14) = "〇"
wsR.Cells(2, 15) = ":単純リラン不可"
wsR.Cells(2, 15).HorizontalAlignment = xlLeft
wsR.Cells(2, 20).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 20).Font.ColorIndex = CHAR_COLOR
wsR.Cells(2, 20).Font.Bold = True
wsR.Cells(2, 20) = "〇"
wsR.Cells(2, 21) = ":DB使用&単純リラン不可"
wsR.Cells(2, 21).HorizontalAlignment = xlLeft
'RESシート内のJOBを順次処理
iRCnt = 0
iR_GYO = 5: iR_RTS_JOB = 2
Do Until _
Trim(wsR.Cells(iR_GYO, iR_RTS_JOB)) = "" Or _
iR_GYO > R_SRCH_LIMIT
'
For iD_RTS_DAY = 3 To 33 Step 1
If Trim(wsR.Cells(iR_GYO, iD_RTS_DAY)) = "〇" Then
'DB使用
If Trim(wsR.Cells(iR_GYO, R_RTS_USEDB)) = "●" Then
wsR.Cells(iR_GYO, iD_RTS_DAY).Interior.ColorIndex = BACK_COLOR
End If
'リラン可能
If Trim(wsR.Cells(iR_GYO, R_RTS_RERUN)) <> "可" Then
'2023.12.16
'wsR.Cells(iR_GYO, iD_RTS_DAY).Interior.ColorIndex = CHAR_COLOR
wsR.Cells(iR_GYO, iD_RTS_DAY).Font.ColorIndex = CHAR_COLOR
wsR.Cells(iR_GYO, iD_RTS_DAY).Font.Bold = True
End If
End If
Next iD_RTS_DAY
iRCnt = iRCnt + 1
'
iR_GYO = iR_GYO + 1
Loop
If iR_GYO > R_SRCH_LIMIT Then
MsgBox R_SHEET & " 最大検索行を縦超えました" & iR_GYO
SetJobAttentionColor = False
End If
'件数
iRCnt = iR_GYO
SetJobAttentionColor = True
End Function
Public Const G_APLNAME As String = "実行スケジュールマン"
Public Const S_DGYO_S As Integer = 15
Public Const S_RTS_S As Integer = 3 'データの開始列
Public Const S_RTS_A1 As String = "C" 'ソース
Public Const WK_DGYO_S As Integer = 5 '出力結果の開始行
Public Const T_GYO_S As Integer = 5 '出力表の値の開始行
Public Const GLAY As Integer = 15 'グレイ
'シート
Public Const W_SHEET As String = "WK"
Public Const T_SHEET As String = "RES"
Public Const N_SHEET As String = "設定"
Public Const R_SHEET As String = "RES"
Public Const A_SHEET As String = "全チーム"
'設定
Public Const N_RTS_S As Integer = 4 ' テーブル開始列
'ソース 凡例
Public Const H_RTS_S As Integer = 15 ' 凡例開始列
Public Const H_SRH_LIMIT As Integer = 8
Public G_DGYO_S As Integer
Public G_S_BOOK As String
Public G_S_SHEET As String
Public G_TUKI As String
Public G_TUKI_YYYY As String
Public G_TUKI_MM As String
Public G_H_GYO_S As Integer
Sub Main()
Application.MacroOptions Macro:="Main", ShortcutKey:="j"
Dim wsN As Worksheet: Set wsN = Worksheets(N_SHEET)
Dim wsW As Worksheet: Set wsW = Worksheets(W_SHEET)
Dim wsT As Worksheet: Set wsT = Worksheets(T_SHEET)
Dim I As Integer
Dim iCnt As Integer
Dim iGyoNoCnt As Integer
Dim iCntUNQJob As Integer
Dim iGYO_LstNo As Integer
Dim iRTS_LstDay As Integer
Dim l As Integer
Dim arr() As String
Dim tmp() As String
Dim WKCALarr() As String
'2023.12.16
Dim iCpyCntJ As Long
Dim iResCntJ As Integer
Dim iResCntT As Integer
Dim iResCntR As Integer
Dim bRC As Boolean
Dim sMsg As String
Dim iResCnt As Integer
Dim sDate As String
Dim sDay As String
'2023.12.16
Dim iResTCnt As Long
' -------------------------------
' 初期処理
' -------------------------------
bRC = IsSeteiCheck()
If bRC = False Then
Exit Sub
End If
' 2023.12.15
'ウインドウ枠の固定
bRC = FreezePanes("RES", 5, 3)
bRC = FreezePanes("RES縦", 5, 11)
Dim wsS As Worksheet: Set wsS = Worksheets(G_S_SHEET)
Worksheets(G_S_SHEET).Activate
'調査範囲(開始行、開始列)で指定文字を行方向へ検索して
'行番号を求めた値を調査範囲の最大行番号とする
iGYO_LstNo = GetGYO_LstNo(wsS, G_DGYO_S, 2, "計")
Debug.Print iGYO_LstNo
If iGYO_LstNo = 0 Then
MsgBox "** ERRR ** iGYO_LstNo= " & iGYO_LstNo
Exit Sub
End If
'調査範囲(開始列、開始行)で指定文字を列方向へ検索して
'列番号を求めた値を調査範囲の最大列番号とする
iRTS_LstDay = GetRTS_LstDay(wsS, S_RTS_S, 13, "")
Debug.Print iRTS_LstDay
If iRTS_LstDay = 0 Then
MsgBox "** ERRR ** iRTS_LstDay= " & iRTS_LstDay
Exit Sub
End If
' -------------------------------
' 主処理
' -------------------------------
Application.ScreenUpdating = False ' 描画を停止する
'調査シートからカレンダー内容を配列へ保存
WKCALarr() = GetCalenderContents(wsS, _
iGYO_LstNo, _
iRTS_LstDay)
'WKシートを編集する
wsW.Activate
iGyoNoCnt = WK_Create(wsW, _
iGYO_LstNo, _
iRTS_LstDay, _
WKCALarr())
iCntUNQJob = WK_SortAndUNQJob(wsW, _
WK_DGYO_S, _
UBound(WKCALarr()))
Debug.Print " iGyoNoCnt= " & iGyoNoCnt & " iCntUNQJob= " & iCntUNQJob
'結果シートへ保存する
iCpyCntJ = Copy_WK_TO_RES(WK_DGYO_S, _
iCntUNQJob, _
WKCALarr())
iResCntT = RES_JOB_Calender(wsT, _
wsW, _
WK_DGYO_S, _
iCntUNQJob, _
WKCALarr())
'結果シートをチーム、JOBの順でデータを昇順に並べ替える
iResCntR = ResSettingJobSort(T_SHEET, _
T_GYO_S, _
T_GYO_S + iCntUNQJob - 1, _
"A", "AG", _
"A", "B")
Dim iACnt As Integer
Dim iRCnt As Integer
bRC = GetJobAttention(iACnt, iRCnt)
If bRC = False Then
sMsg = "注目項目のセットエラー"
MsgBox sMsg, vbInformation, G_APLNAME
End If
bRC = SetJobAttentionColor(iRCnt)
If bRC = False Then
sMsg = "注目項目の強調表示エラー"
MsgBox sMsg, vbInformation, G_APLNAME
End If
' -------------------------------
' 後処理
' -------------------------------
Application.ScreenUpdating = True ' 描画を再開する
iResTCnt = RESTATE_FromWK("RES縦", 5)
'2023.12.16
'印刷設定
bRC = PrintSetup("RES", "A", 2, "AI", iCpyCntJ, "A3", "横")
bRC = PrintSetup("RES縦", "B", 2, "V", iResTCnt + 4, "A3", "横")
If BookCopyMultiSheeet("RES", "RES縦") = False Then
Exit Sub
End If
sMsg = G_S_SHEET & " 分析シート " & G_S_SHEET & vbCrLf & _
"検索範囲 " & vbCrLf & _
" 縦 " & G_DGYO_S & " 行 ～" & " 終了 " & iGYO_LstNo & " 行 " & _
vbCrLf & _
" 横 " & 3 & " 列 ～" & iRTS_LstDay & " 列 " & vbCrLf & _
vbCrLf & _
" 年.月" & G_TUKI & vbCrLf & _
vbCrLf & _
"中間 " & iCpyCntJ & " 件 " & iGyoNoCnt & " 件" & vbCrLf & _
vbCrLf & _
" 実施JOB回数（取得/全体） " & " JOB数: " & iResCntT & " / " & iGyoNoCnt & _
vbCrLf & _
" 実施JOB件数 " & " JOB数: " & iCntUNQJob & " ソート行数 " & iResCntR & vbCrLf & _
"" & vbCrLf & _
" 強調表示項目の処理" & vbCrLf & _
" RESシート 件数:" & iRCnt & " 全チームシート 件数: " & iACnt
MsgBox sMsg, vbInformation, G_APLNAME
End Sub
'2023.12.16
Public Function PrintSetup(SHName As String, _
S_col As String, S_row As Long, _
E_col As String, E_row As Long, _
sSize As String, sHoukou As String) As Boolean
PrintSetup = False
If sSize = "A4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "A3" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "B4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
Exit Function
End If
End If
End If
With Sheets(SHName).PageSetup
' 範囲
.PrintArea = S_col & S_row & ":" & E_col & E_row + 3
'用紙サイズと方向
.Orientation = xlPortrait
.PaperSize = xlPaperA4
' 余白
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
' 中央
.CenterHorizontally = True 'CenterVertically
' 向き
.Orientation = xlLandscape ' xlPortrait
' ズーム(すべての列を1ページ)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
'ヘッダーとフッター
.CenterHeader = "&A"
.RightHeader = "&D"
.CenterFooter = "&P" & "/" & "&N"
End With
PrintSetup = True
End Function
'2023.12.15
'ウインドウ枠の固定
Function FreezePanes(ShName1 As String, iGYO As Integer, iRTU As Integer) As Boolean
Worksheets(ShName1).Activate
Cells(iGYO, iRTU).Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
FreezePanes = True
End Function
' 外部ブックとして保存
Public Function BookCopyMultiSheeet(ShName1 As String, ShName2 As String) As Boolean
Dim wb As Workbook
Dim sFileName As String
Dim sFileNameFull As String
Dim sMsg As String
sFileName = "結果_" & G_S_SHEET & "_" & G_TUKI_YYYY & G_TUKI_MM & Format(Now, "yymmddhhnn") & ".xlsx"
sFileNameFull = ThisWorkbook.Path & "\" & sFileName
If Dir(sFileNameFull) <> "" Then
sMsg = sFileName & vbCrLf & "が存在します"
MsgBox sMsg, vbInformation, G_APLNAME
BookCopyMultiSheeet = False
Exit Function
End If
Sheets(Array(ShName1, ShName2)).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs Filename:=sFileNameFull
wb.Close
Application.DisplayAlerts = True
BookCopyMultiSheeet = True
End Function
Public Function IsSeteiCheck() As Boolean
IsSeteiCheck = False
Dim wsN As Worksheet: Set wsN = Worksheets(N_SHEET)
Dim sMsg As String
Dim iRC As Integer
G_S_BOOK = sGetSettingValue(wsN, 2, 4)
G_S_SHEET = sGetSettingValue(wsN, 3, 4) ' 設定 分析シート
G_DGYO_S = iGetSettingValue(wsN, 4, 4) ' 設定 分析凡例開始行
G_H_GYO_S = sGetSettingValue(wsN, 5, 4) ' 設定 分析開始行
G_TUKI = sGetSettingValue(wsN, 6, 4) ' 設定 年月
'シート存在チェック
If IsExistsSheet(G_S_SHEET) = False Then
MsgBox "設定 シートなし " & G_S_SHEET, vbCritical, G_APLNAME
Exit Function
End If
'年月 チェック
If IsYYYYMM(G_TUKI) = False Then
Exit Function
End If
'分析開始行 チェック
If IsGyoNo(G_DGYO_S) = False Then
MsgBox "分析開始行誤 " & G_DGYO_S, vbCritical, G_APLNAME
Exit Function
End If
' 設定チェック
sMsg = " 分析シート : " & G_S_SHEET & vbCrLf & _
" 凡例開始行 : " & G_H_GYO_S & vbCrLf & _
" 値開始行 : " & G_DGYO_S & vbCrLf & _
" 年月(yyyy/mm) : " & G_TUKI
iRC = MsgBox(sMsg, vbYesNo + vbQuestion, G_APLNAME)
If iRC <> vbYes Then
MsgBox "処理を中止しました", vbExclamation, G_APLNAME
Exit Function
End If
'凡例開始行 チェック
If IsGyoNo(G_H_GYO_S) = False Then
MsgBox "凡例開始行誤 " & G_H_GYO_S, vbCritical, G_APLNAME
Exit Function
End If
IsSeteiCheck = True
End Function
Public Function IsGyoNo(ByVal G_DGYO_S As String)
Dim I As Long
Dim Buf As Variant '配列を指定
IsGyoNo = False
If IsNumeric(G_DGYO_S) = False Then
MsgBox "設定 分析開始行 " & G_DGYO_S, vbCritical, G_APLNAME
Exit Function
End If
IsGyoNo = True
End Function
' 年月チェック
Public Function IsYYYYMM(ByVal G_TUKI As String)
Dim I As Long
Dim Buf As Variant '配列を指定
Dim sYYYY As String
Dim sMM As String
IsYYYYMM = False
Buf = Split(G_TUKI, "/") '区切りで分割
For I = 0 To UBound(Buf) '配列に分割して格納したデータを繰返。
Debug.Print Buf(I)
Next I
Debug.Print UBound(Buf)
If UBound(Buf) <> 1 Then
MsgBox "設定 年月:形式エラー " & G_TUKI, vbCritical, G_APLNAME
Exit Function
End If
sYYYY = Buf(0)
sMM = Buf(1)
If IsNumeric(sYYYY) = False Then
MsgBox "設定 年月:年 " & sYYYY, vbCritical, G_APLNAME
Exit Function
End If
If IsNumeric(sMM) = False Then
MsgBox "設定 年月:月 " & sMM, vbCritical, G_APLNAME
Exit Function
Else
If sMM < 1 Or sMM > 12 Then
MsgBox " 年月:月範囲 " & sMM, vbCritical, G_APLNAME
Exit Function
End If
End If
G_TUKI_YYYY = sYYYY
G_TUKI_MM = sMM
IsYYYYMM = True
End Function
' Sheets に指定した名前のシートの存在確認
Public Function IsExistsSheet(ByVal SHName As String)
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
' カレンダー日の順に並替
Function RESTATE_FromWK(sh As String, _
iGYOS As Integer) As Integer
Dim iGYOE As Integer
Dim iSortCnt As Integer
Dim bRC As Boolean
RESTATE_FromWK = 0
With Worksheets(sh)
.Cells.Clear
End With
Sheets("WK").Select
Cells.Select
Selection.Copy
'
Worksheets(sh).Activate
Sheets(sh).Select
Sheets(sh).Cells(1, 1).Select
ActiveSheet.Paste
'
Range("C5:C5").Select
Range(Selection, Selection.End(xlDown)).Select
iGYOE = Selection.End(xlDown).Row
'
Application.CutCopyMode = False
ActiveWorkbook.Worksheets(sh). _
Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range("C" & iGYOS, "C" & iGYOE), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range("D" & iGYOS, "D" & iGYOE), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(sh).Sort
.SetRange Range("B" & iGYOS, "J" & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
iSortCnt = iGYOE - iGYOS + 1
Sheets(sh).Cells(iGYOS - 1, 2).Value = "曜"
Sheets(sh).Cells(iGYOS - 1, 3).Value = "日"
Sheets(sh).Cells(iGYOS - 1, 4).Value = "順"
Sheets(sh).Cells(iGYOS - 1, 5).Value = "JOB名"
Sheets(sh).Cells(iGYOS - 1, 6).Value = "夜"
Sheets(sh).Cells(iGYOS - 1, 7).Value = "回目"
Sheets(sh).Cells(iGYOS - 1, 8).Value = "Step数"
Sheets(sh).Cells(iGYOS - 1, 9).Value = "File数"
Sheets(sh).Cells(iGYOS - 1, 10).Value = "周期"
Sheets(sh).Cells(iGYOS - 1, 11).Value = "業務"
Sheets(sh).Cells(iGYOS - 1, 12).Value = "時刻"
Sheets(sh).Cells(iGYOS - 1, 13).Value = "昼夜"
Sheets(sh).Cells(iGYOS - 1, 15).Value = "スケジュール日△業務コード"
Sheets(sh).Cells(iGYOS - 1, 16).Value = "→結果(1)業務ＣＤ"
Sheets(sh).Cells(iGYOS - 1, 17).Value = "→結果(2)実行予定"
Sheets(sh).Cells(iGYOS - 1, 18).Value = "→結果(3)曜日"
Sheets(sh).Cells(iGYOS - 1, 20).Value = "①②ジョブ名（UNIQ）"
Sheets(sh).Cells(iGYOS - 1, 21).Value = "→結果 業務ＣＤ"
Sheets(sh).Cells(iGYOS - 1, 22).Value = "→結果 開始時刻"
Sheets(sh).Cells(iGYOS - 2, 3).Value = G_TUKI
Sheets(sh).Cells(iGYOS - 2, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 3, 3).Value = G_S_SHEET
Sheets(sh).Cells(iGYOS - 3, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 1, 3).HorizontalAlignment = xlLeft
Sheets(sh).Cells(iGYOS - 2, 7).Value = iSortCnt
Sheets(sh).Cells(iGYOS - 1, 15).ColumnWidth = 25
Sheets(sh).Cells(iGYOS - 1, 16).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 17).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 18).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 20).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 21).ColumnWidth = 20
Sheets(sh).Cells(iGYOS - 1, 22).ColumnWidth = 20
'罫線③ 2023.12.01
With Sheets(sh).Range(Cells(5, 15), Cells(iGYOE, 18))
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'高さ
Rows("2:4").RowHeight = 25
Sheets(sh).Cells(1, 15) = "カレンダ日別の業務オンライン照会結果"
With Sheets(sh).Range("o" & 2, "V" & 2)
.Interior.ColorIndex = 3
.Font.Bold = True
End With
' 2023.12.01
Sheets(sh).Cells(2, 15) = "機械化調査（mac施順①→②→③"
Sheets(sh).Cells(3, 15) = "③稼働日の照合"
Sheets(sh).Cells(3, 21) = "①業務CD取得"
Sheets(sh).Cells(3, 22) = "②稼働時刻取得"
Sheets(sh).Cells(3, 15).WrapText = True
Sheets(sh).Cells(3, 21).WrapText = True
Sheets(sh).Cells(3, 22).WrapText = True
'フィルター設定
Sheets(sh).Rows("4:4").Select
Selection.AutoFilter
' サマリー件数を求める
bRC = Kensu("RES縦", iSortCnt)
RESTATE_FromWK = iSortCnt
End Function
'2023.12.01
Function Kensu(sh As String, iSortCnt As Integer) As Boolean
Kensu = False
'回目
Range("I7:I7").Select
Sheets(sh).Cells(3, 7).FormulaR1C1 = "=SUBTOTAL(103,R[2]C:R[" & iSortCnt + 1 & "]C)"
'Step数
Sheets(sh).Cells(3, 8).FormulaR1C1 = "=SUBTOTAL(109,R[2]C:R[" & iSortCnt + 1 & "]C)"
'File数
Sheets(sh).Cells(3, 9).FormulaR1C1 = "=SUM(R[2]C:R[" & iSortCnt + 1 & "]C)"
'JOB(重複除外)
Sheets(sh).Cells(3, 20).FormulaR1C1 = "=COUNTA(R[2]C:R[" & iSortCnt + 1 & "]C)"
Kensu = True
End Function
'
'指定範囲をキーを指定してデータソートする
Function ResSettingJobSort(sh As String, _
iGYOS As Integer, _
iGYOE As Integer, _
sRTSS As String, _
sRTSE As String, _
sKey1 As String, _
sKey2 As String) As Integer
Range(sRTSS & iGYOS, sRTSE & iGYOE).Select
ActiveWorkbook.Worksheets(sh).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh).Sort.SortFields. _
Add Key:=Range(sKey1 & iGYOS, sKey1 & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(sh).Sort.SortFields.Add Key _
:=Range(sKey2 & iGYOS, sKey2 & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(sh).Sort
.SetRange Range(sRTSS & iGYOS, sRTSE & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ResSettingJobSort = iGYOE - iGYOS + 1
End Function
'
Function WK_Create(wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const W_GYO_H As Integer = 4
Dim I As Integer
Dim l As Integer
Dim tmp() As String
Dim bRC As Boolean
With Worksheets(W_SHEET)
.Cells.Clear
End With
'共通フォーマット設定
bRC = W_COMM_FORMAT(wsW, W_GYO_H)
l = WK_DGYO_S
For I = 0 To UBound(WKCALarr())
'Debug.Print WKCALarr(i)
tmp = Split(WKCALarr(I), ":")
wsW.Cells(l, 3) = tmp(0) ' 日
wsW.Cells(l, 4) = tmp(1) ' 日内の順番
wsW.Cells(l, 5) = tmp(2) ' JOB
wsW.Cells(l, 6) = tmp(3) ' 回目
wsW.Cells(l, 7) = tmp(4) ' 日・夜
wsW.Cells(l, 8) = tmp(5) ' ステップ数
wsW.Cells(l, 9) = tmp(6) ' ファイル数
wsW.Cells(l, 10) = tmp(7) ' 周期
On Error Resume Next
Dim sDate
sDate = G_TUKI & "/" & Trim(wsW.Cells(l, 3))
wsW.Cells(l, 2) = WeekdayName(Weekday(sDate), True)
' 背景色
wsW.Cells(l, 3).Interior.Color = tmp(8)
wsW.Cells(l, 4).Interior.Color = tmp(8)
wsW.Cells(l, 5).Interior.Color = tmp(8)
wsW.Cells(l, 6).Interior.Color = tmp(8)
wsW.Cells(l, 7).Interior.Color = tmp(8)
wsW.Cells(l, 8).Interior.Color = tmp(8)
wsW.Cells(l, 9).Interior.Color = tmp(8)
wsW.Cells(l, 10).Interior.Color = tmp(8)
l = l + 1
Next I
' 罫線
With wsW.Range("C" & WK_DGYO_S, "J" & l - 1)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'ソート
Range("B" & WK_DGYO_S, "J" & l - 1).Select
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Clear
'ソートキー1
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add Key _
:=Range("C" & WK_DGYO_S, "C" & l - 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
'ソートキー2
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add Key _
:=Range("D" & WK_DGYO_S, "D" & l - 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
'ソート
With ActiveWorkbook.Worksheets(W_SHEET).Sort
.SetRange Range("B" & WK_DGYO_S, "J" & l - 1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
WK_Create = l - WK_DGYO_S
End Function
'
Function W_COMM_FORMAT(wsW As Worksheet, _
W_GYO_H As Integer) As Boolean
W_COMM_FORMAT = False
' フォント
With Worksheets(W_SHEET).Cells.Font
.Name = "Meiryo UI"
.Size = 11
End With
' 列の幅
wsW.Range("A" & W_GYO_H).Cells.ColumnWidth = 2
wsW.Range("B" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("C" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("D" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("E" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("F" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("G" & W_GYO_H).Cells.ColumnWidth = 14
wsW.Range("H" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("I" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("J" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("K" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("L" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("M" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("N" & W_GYO_H).Cells.ColumnWidth = 1
wsW.Range("O" & W_GYO_H).Cells.ColumnWidth = 20
wsW.Range("P" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("Q" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("R" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("S" & W_GYO_H).Cells.ColumnWidth = 1
wsW.Range("L" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("M" & W_GYO_H).Cells.ColumnWidth = 10
wsW.Range("N" & W_GYO_H).Cells.ColumnWidth = 4
wsW.Range("T" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("U" & W_GYO_H).Cells.ColumnWidth = 8
wsW.Range("V" & W_GYO_H).Cells.ColumnWidth = 8
'書式
Columns("C:D").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("F:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
W_COMM_FORMAT = True
End Function
'
Function T_COMM_FORMAT(wsT As Worksheet, _
T_GYO_H As Integer) As Boolean
T_COMM_FORMAT = False
' フォント
With Worksheets(T_SHEET).Cells.Font
.Name = "Meiryo UI"
.Size = 11
End With
'書式
Columns("C:AG").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ColumnWidth = 5
End With
Columns("F:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Columns("J:J").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
T_COMM_FORMAT = True
End Function
'
Function Copy_WK_TO_RES(iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const W_RTS_S_A1 As String = "T" 'コピー元のの開始列
Const T_RTS_S_A1 As String = "B" '出力表の値の開始列
Const T_GYO_S As Integer = 5 '出力表の値の開始行
Dim wsW As Worksheet: Set wsW = Worksheets(W_SHEET)
Dim wsT As Worksheet: Set wsT = Worksheets(T_SHEET)
Dim iGYOE As Integer
Copy_WK_TO_RES = 0
iGYOE = iGYOS + iCnt - 1
With Worksheets(T_SHEET)
.Cells.Clear
End With
Application.CutCopyMode = False
Worksheets(W_SHEET).Range(W_RTS_S_A1 & iGYOS, W_RTS_S_A1 & iGYOE).Select
Selection.Copy
Worksheets(T_SHEET).Activate
Sheets(T_SHEET).Select
Range(T_RTS_S_A1 & T_GYO_S).Select
ActiveSheet.Paste
Copy_WK_TO_RES = iCnt
End Function
'
Function RES_JOB_Calender(wsT As Worksheet, _
wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer, _
ByRef WKCALarr() As String) As Integer
Const S_GYO_S As Integer = 5 '入力データ開始行
Const W_GYO_S As Integer = 5 '入力データ開始行
Const W_GYO_DAY As Integer = 3 '入力データ開始列(日付)
Const W_RTS_JOB As Integer = 5 '入力データ開始列(JOB)
Const T_RTS_JOB As Integer = 2 '出力表の開始列(JOB)
Const T_RTS_DAY As Integer = 3 '出力表の開始列(日付)
Const T_GYO_S As Integer = 5 '出力表の値の開始行
Const T_RTS_S As Integer = 2 '出力表の値の開始列
Const E_RTS_DAY As Integer = 34 '日付の終了列
Dim iGYOE As Integer
Dim iLastCnt As Integer
Dim iResCnt As Integer
Dim j As Integer
Dim I As Integer
Dim iHDR1GYO As Integer
Dim iHDR2GYO As Integer
Dim iDayS As Integer
Dim iGyoTOT As Integer
Dim iDayNo As Integer
Dim s As Integer
Dim w As Integer
Dim t As Integer
Dim tGyo As Integer
Dim sCntMax As Integer
Dim tCntMax As Integer
Dim bRC As Boolean
RES_JOB_Calender = 0
iGYOE = iGYOS + iCnt - 1
iGyoTOT = T_GYO_S + iCnt
'共通フォーマット設定
bRC = T_COMM_FORMAT(wsT, 1)
' ----------------------------
' 表 ヘッダー タイトル
' ----------------------------
iHDR1GYO = T_RTS_DAY
iHDR2GYO = T_RTS_DAY + 1
wsT.Range(Cells(iHDR1GYO, W_GYO_DAY), Cells(iHDR1GYO, E_RTS_DAY)). _
Borders.LineStyle = xlContinuous
Range("C3:AG3").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
iDayS = T_RTS_DAY
wsT.Cells(iHDR1GYO, iDayS - 1).Value = "JOB名"
wsT.Cells(iHDR2GYO, iDayS - 1).Value = ""
iDayNo = 1
For I = iDayS To iDayS + 31 Step 1
wsT.Cells(iHDR2GYO, I).Value = iDayNo
wsT.Cells(iHDR2GYO, I).Borders.LineStyle = xlContinuous
wsT.Cells(iHDR2GYO, I).HorizontalAlignment = xlLeft
wsT.Cells(iHDR2GYO, I).VerticalAlignment = xlCenter
iDayNo = iDayNo + 1
Next I
wsT.Range("C3").Value = G_TUKI
' ----------------------------
' 表 コンテンツ レイアウト
' ----------------------------
j = T_GYO_S
I = 3
wsT.Range(Cells(j, I), Cells(j + iCnt, I + 31)). _
Borders.LineStyle = xlContinuous
wsT.Range("C" & j, "AG" & iCnt + 5).HorizontalAlignment = xlCenter
wsT.Range("C" & j, "AG" & iCnt + 5).VerticalAlignment = xlCenter
' 横合計の計算値を挿入
' 縦の集計行
wsT.Range("AH" & iGYOS).Cells.ColumnWidth = 5
wsT.Range("AI" & iGYOS).Cells.ColumnWidth = 5
wsT.Cells(iHDR1GYO, 34).Value = "実行"
wsT.Cells(iHDR2GYO, 34).Value = "回数"
wsT.Cells(iHDR1GYO, 34).Interior.ColorIndex = GLAY
wsT.Cells(iHDR2GYO, 34).Interior.ColorIndex = GLAY
For I = T_GYO_S To iCnt + T_GYO_S Step 1
wsT.Range("AH" & I).Formula = _
"=COUNTIF($C" & I & ":" & "$AG" & I & ",""〇"")"
wsT.Range("AH" & I).Interior.ColorIndex = GLAY
Next I
'合計の合計
wsT.Range("AI" & I - 1).Formula = _
"=SUM($AH" & T_GYO_S & ":" & "$AH" & I - 1 & ")"
' 横の集計行
iDayS = T_RTS_DAY
wsT.Cells(iGyoTOT, iDayS - 1).Value = "JOB数"
wsT.Range(Cells(iGyoTOT, iDayS - 1), Cells(iGyoTOT, iDayS + 31)). _
Borders.LineStyle = xlContinuous
For I = iDayS To iDayS + 30 Step 1
wsT.Cells(iGyoTOT, I).FormulaR1C1 = _
"=COUNTIF(R[-" & iCnt + 1 & "]C" & ":" & "R[-1]C,""〇"")"
wsT.Cells(iGyoTOT, I).Interior.ColorIndex = GLAY
Next I
'合計の合計
wsT.Range("AG" & iGyoTOT + 1).Formula = _
"=SUM($C" & iGyoTOT & ":" & "$AG" & iGyoTOT & ")"
'フィルター設定
wsT.Rows("4:4").Select
Selection.AutoFilter
wsT.Cells(iHDR1GYO - 2, 1).Value = G_S_SHEET
wsT.Cells(iHDR1GYO, 1).Value = "チーム名"
' ----------------------------
' チーム名のセット
' ----------------------------
bRC = GetTeamNameAndFormat(wsW, wsT, iCnt)
' ----------------------------
' 個々の該当識別のセット
' ----------------------------
tGyo = T_GYO_S
sCntMax = UBound(WKCALarr()) + 1
tCntMax = iCnt
For w = W_GYO_S To sCntMax + W_GYO_S
For t = tGyo To tCntMax + T_GYO_S
If Trim(wsT.Cells(t, T_RTS_JOB).Value) = _
Trim(wsW.Cells(w, W_RTS_JOB).Value) Then
'出力表の開始列に入力日付の値を足した位置
j = T_RTS_S + wsW.Cells(w, W_GYO_DAY).Value
wsT.Cells(t, j).Value = "〇"
If InStr(1, wsW.Cells(w, W_GYO_DAY + 4).Value, "X") > 0 Then
wsT.Cells(t, j).Value = "〇→X"
End If
'出力表の検索開始行を更新する
tGyo = t
Exit For
End If
Next t
'Debug.Print "s=" & s
Next w
wsT.Cells(iGYOS - 3, 1).Value = "● " & G_S_SHEET
wsT.Cells(iGYOS - 3, 1).HorizontalAlignment = xlLeft
wsT.Cells(iGYOS - 3, 4).Value = "〇→X " & G_S_SHEET
wsT.Cells(iGYOS - 3, 4).HorizontalAlignment = xlLeft
wsT.Cells(iGYOS - 2, 1).Value = "担当T"
RES_JOB_Calender = wsT.Range("AG" & iGyoTOT + 1).Value
End Function
'
Function WK_SortAndUNQJob(wsW As Worksheet, _
iGYOS As Integer, _
iCnt As Integer) As Integer
Dim iGYOE As Integer
Dim iLastCnt As Integer
Dim iResCnt As Integer
wsW.Range("K" & iGYOS).Cells.ColumnWidth = 2
iGYOE = iGYOS + iCnt
wsW.Activate
wsW.Range("B" & iGYOS, "J" & iGYOS).Select
wsW.Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Clear
' JOBの昇順（第1キー)
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add _
Key:=Range("E" & iGYOS, "E" & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
' 日付の昇順（第2キー)
ActiveWorkbook.Worksheets(W_SHEET).Sort.SortFields.Add _
Key:=Range("C" & iGYOS, "C" & iGYOE), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
' 並び替え
With ActiveWorkbook.Worksheets(W_SHEET).Sort
.SetRange Range("B" & iGYOS, "J" & iGYOE)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Debug.Print "JobAllCnt= " & iGYOE - iGYOS
'重複削除の為にJOB枠のコピー
wsW.Range("E" & iGYOS, "E" & iGYOS).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("T" & iGYOS).Select
ActiveSheet.Paste
' 重複削除を実行してJOB一覧を作成
wsW.Range("T" & iGYOS, "T" & iGYOS).Select
wsW.Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-102
Application.CutCopyMode = False
ActiveSheet.Range("$T$" & iGYOS, "$T$" & iGYOE).RemoveDuplicates _
Columns:=1, Header:=xlNo
' 重複削除の結果件数
On Error Resume Next
iResCnt = wsW.Range("T" & iGYOS).End(xlDown).Row
'罫線
With wsW.Range("T" & WK_DGYO_S, "V" & iResCnt)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
wsW.Range("K" & 1).Cells.ColumnWidth = 6
wsW.Range("L" & 1).Cells.ColumnWidth = 10
wsW.Range("M" & 1).Cells.ColumnWidth = 4
wsW.Range("O" & 1).Cells.ColumnWidth = 20
'設定シートから年月を取得
Dim wsQ As Worksheet
Set wsQ = Worksheets("設定")
wsW.Range("C3").Value = wsQ.Range("D6")
' JOB名と紐つく業務CDと時刻
Dim iV As Integer
For iV = iGYOS To iGYOE Step 1
'(K列) 業務コードの引当
wsW.Range("$K" & iV).Formula = "=VLOOKUP($E" & iV & ",$T:$U,2,false)"
'(L列) 稼働時刻の引当
wsW.Range("$L" & iV).Formula = "=TEXT(VLOOKUP($E" & iV & ",$T:$V,3,false)," & _
"""HH:MM:SS""" & ")"
'(M列) 昼夜識別記号
wsW.Range("$M" & iV).Formula = "=IF(OR($L" & iV & ">" & """#09:30:00""" & ", " & _
"$L" & iV & "<" & """#04:25:00""" & "), " & _
"""●""" & "," & """ """ & "" & ")"
'(O列) スケジュール日＋△＋業務コード
wsW.Range("$O" & iV).Formula = "=RIGHT(TEXT($C$3,""YYYYMM"")" & ",4)" & _
" & TEXT($C" & iV & "," & """00""" & ")" & _
" & " & """ """ & _
" & $K" & iV
Next
iResCnt = iResCnt - iGYOS + 1
WK_SortAndUNQJob = iResCnt
End Function
'
Function GetCalenderContents(wsS As Worksheet, _
iGYO_LstNo As Integer, _
iRTS_LstDay As Integer) As String()
Const S_RTS_NO_STA As Integer = 2 '
Dim I As Integer
Dim j As Integer
Dim k As Integer
Dim iCellMaxNo As Integer
Dim iCellMaxMaxNo As Integer
Dim arr() As String
Dim sCycle As String
Dim iOutFg As Integer
Dim arrLen As Long
Dim val As Variant
Dim ivalCnt As Integer
iCellMaxMaxNo = iGYO_LstNo * iRTS_LstDay
ReDim arr(0 To iCellMaxMaxNo)
j = 3
k = 0
For j = S_RTS_S To iRTS_LstDay Step 5
'Debug.Print "■G_DGYO_S=" & G_DGYO_S
For I = iGYO_LstNo To G_DGYO_S Step -1
iOutFg = 0
If InStr(wsS.Cells(I, j), "日次") > 0 Or _
InStr(wsS.Cells(I, j), "週次") > 0 Or _
InStr(wsS.Cells(I, j), "月次") > 0 Or _
InStr(wsS.Cells(I, j), "年次") > 0 Then
sCycle = wsS.Cells(I, j)
Else
If Trim(wsS.Cells(I, j)) <> "" Then
iOutFg = 1
End If
End If
If iOutFg = 1 Then
arr(k) = _
wsS.Cells(13, j) & ":" & _
wsS.Cells(I, 2) & ":" & _
wsS.Cells(I, j) & ":" & _
wsS.Cells(I, j + 1) & ":" & _
wsS.Cells(I, j + 2) & ":" & _
wsS.Cells(I, j + 3) & ":" & _
wsS.Cells(I, j + 4) & ":" & _
sCycle & ":" & _
wsS.Cells(I, j).Interior.Color
k = k + 1
End If
Next
Next
For Each val In arr
'Debug.Print val
If val = "" Then
ivalCnt = ivalCnt + 1
End If
Next
'
arrLen = UBound(arr) - ivalCnt
If arrLen < 0 Then
arrLen = 0
End If
ReDim Preserve arr(arrLen)
'ReDim Preserve arr(UBound(arr) - ivalCnt)
GetCalenderContents = arr()
End Function
' Noの値の最大行番号を求める
Function GetGYO_LstNo(wsS As Worksheet, _
I As Integer, _
S_RTS_NO As Integer, _
sSrhChar As String) As Integer
Const S_SRH_GYO_MAXCNT As Integer = 1000 '
Dim iCnt As Integer
iCnt = I
GetGYO_LstNo = 0
Do Until _
Trim(wsS.Cells(iCnt, S_RTS_NO).Value) = sSrhChar Or _
iCnt > S_SRH_GYO_MAXCNT
iCnt = iCnt + 1
Loop
GetGYO_LstNo = iCnt - 1
End Function
' 月末の値の最大列番号を求める
Function GetRTS_LstDay(wsS As Worksheet, _
j As Integer, _
S_GYO_DAY As Integer, _
sSrhChar As String) As Integer
Const S_SRH_RTS_MAXCNT As Integer = 500 '
GetRTS_LstDay = 0
Do Until _
Trim(wsS.Cells(S_GYO_DAY, j)) = sSrhChar Or _
j > S_SRH_RTS_MAXCNT
j = j + 5
Loop
GetRTS_LstDay = j - 1
End Function
' カラーコードを元にチーム名を取得する
Function GetTNameByColorCd(iColorCd As Long) As String
Dim wsS As Worksheet: Set wsS = Worksheets(G_S_SHEET)
Dim sName As String
Dim I As Integer
sName = ""
I = G_H_GYO_S
Do Until _
Trim(wsS.Cells(I, H_RTS_S)) = "" Or _
I > G_H_GYO_S + H_SRH_LIMIT
If wsS.Cells(I, H_RTS_S).Interior.Color = iColorCd Then
sName = wsS.Cells(I, H_RTS_S).Value
Exit Do
End If
I = I + 1
Loop
If I > G_H_GYO_S + H_SRH_LIMIT Then
MsgBox "XGetTNameByColorCd チーム最大検索数 " & H_SRH_LIMIT & " を超過"
End If
GetTNameByColorCd = sName
End Function
'
Function GetTeamNameAndFormat(wsW As Worksheet, wsT As Worksheet, iCnt As Integer) As Boolean
' ----------------------------
' チーム名のセット
' ----------------------------
Const T_RTS_Setting As Integer = 1 '出力表の開始列(設定)
Const T_RTS_JOB As Integer = 2 '出力表の開始列(JOB)
Dim tGyo As Integer
Dim t As Integer
tGyo = T_GYO_S
For t = T_GYO_S To iCnt + T_GYO_S
' 背景色
wsT.Cells(t, T_RTS_Setting).Interior.Color = _
wsT.Cells(t, T_RTS_JOB).Interior.Color
' 名前
wsT.Cells(t, T_RTS_Setting).Value = _
GetTNameByColorCd(wsT.Cells(t, 1).Interior.Color)
' 線
wsT.Cells(t, T_RTS_Setting).Borders.LineStyle = xlContinuous
Next t
End Function
'
Function iGetSettingValue(wsN As Worksheet, _
I As Integer, j As Integer) As Integer
Dim iValue As Integer
iValue = 0
iValue = Trim(wsN.Cells(I, j).Value)
iGetSettingValue = iValue
End Function
'
Function sGetSettingValue(wsN As Worksheet, _
I As Integer, j As Integer) As String
Dim sValue As String
sValue = ""
sValue = Trim(wsN.Cells(I, j).Value)
sGetSettingValue = sValue
End Function
' ============================================================
' = JOB単位に注意項目を求める
' ============================================================
Function GetJobAttention(ByRef iACnt, ByRef iRCnt) As Boolean
Const R_SRCH_LIMIT As Integer = 500 '検索上限値
Const R_RTS_RERUN As Integer = 37 '単純リラン不可 列番号
Const R_RTS_USEDB As Integer = 38 'DB使用 列番号
Const R_RTS_A_REFLINE As Integer = 39 '全シートの参照行
Const A_SRCH_LIMIT As Integer = 3600 '検索上限値
Const A_RTS_RERUN As Integer = 17 '全シート 単純リラン不可 列番号
Const A_RTS_USEDB As Integer = 117 '全シート DB使用 列番号
Dim wsR As Worksheet: Set wsR = Worksheets(R_SHEET)
Dim wsA As Worksheet: Set wsA = Worksheets(A_SHEET)
Dim iR_RTS_JOB As Integer
Dim iR_RTS_ReRun As Integer
Dim iR_RTS_UseDB As Integer
Dim iR As Integer
Dim iA_RTS_JOB As Integer
Dim iA_RTS_ReRun As Integer
Dim iA_RTS_UseDB As Integer
Dim iA As Integer
Dim sJobName As String
GetJobAttention = False
' - R -
iRCnt = 0: iACnt = 0
sJobName = ""
iR = 5: iR_RTS_JOB = 2
Do Until _
Trim(wsR.Cells(iR, iR_RTS_JOB)) = "" Or _
iR > R_SRCH_LIMIT
' - A -
iACnt = 0
sJobName = Trim(wsR.Cells(iR, iR_RTS_JOB))
iA = 8: iA_RTS_JOB = 5
Do Until _
Trim(wsA.Cells(iA, iA_RTS_JOB)) = "" Or _
iA > A_SRCH_LIMIT
If Trim(wsA.Cells(iA, iA_RTS_JOB)) = sJobName Then
'リラン可能
wsR.Cells(iR, R_RTS_RERUN) = Trim(wsA.Cells(iA, A_RTS_RERUN))
'DB使用
wsR.Cells(iR, R_RTS_USEDB) = Trim(wsA.Cells(iA, A_RTS_USEDB))
' 前シートの行数
wsR.Cells(iR, R_RTS_A_REFLINE) = iA
Exit Do
End If
iA = iA + 1
Loop
If iA > A_SRCH_LIMIT Then
MsgBox sJobName & A_SHEET & " 最大検索行を超えました" & iA
GetJobAttention = False
End If
iR = iR + 1
Loop
If iR > R_SRCH_LIMIT Then
MsgBox sJobName & R_SHEET & " 最大検索行を超えました" & iR
GetJobAttention = False
End If
'件数
iACnt = iA
iRCnt = iR
GetJobAttention = True
End Function
'
' ============================================================
' = 注意項目の強調表示をする
' ============================================================
Function SetJobAttentionColor(ByRef iRCnt) As Boolean
Const CHAR_COLOR As Integer = 7 '文字色（ピンク）
Const BACK_COLOR As Integer = 6 '背景色（黄色）
Const R_RTS_RERUN As Integer = 37 '単純リラン不可 列番号
Const R_RTS_USEDB As Integer = 38 'DB使用 列番号
Const R_SRCH_LIMIT As Integer = 500 '検索上限値
Dim wsR As Worksheet: Set wsR = Worksheets(R_SHEET)
Dim iR_RTS_JOB As Integer
Dim iR_RTS_ReRun As Integer
Dim iR_RTS_UseDB As Integer
Dim iR_GYO As Integer
Dim iD_RTS_DAY As Integer
SetJobAttentionColor = False
'凡例
wsR.Cells(2, 9).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 9) = "〇"
wsR.Cells(2, 10) = ":DB使用"
wsR.Cells(2, 10).HorizontalAlignment = xlLeft
wsR.Cells(2, 14).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 14).Font.Bold = True
wsR.Cells(2, 14) = "〇"
wsR.Cells(2, 15) = ":単純リラン不可"
wsR.Cells(2, 15).HorizontalAlignment = xlLeft
wsR.Cells(2, 20).Interior.ColorIndex = BACK_COLOR
wsR.Cells(2, 20).Font.ColorIndex = CHAR_COLOR
wsR.Cells(2, 20).Font.Bold = True
wsR.Cells(2, 20) = "〇"
wsR.Cells(2, 21) = ":DB使用&単純リラン不可"
wsR.Cells(2, 21).HorizontalAlignment = xlLeft
'RESシート内のJOBを順次処理
iRCnt = 0
iR_GYO = 5: iR_RTS_JOB = 2
Do Until _
Trim(wsR.Cells(iR_GYO, iR_RTS_JOB)) = "" Or _
iR_GYO > R_SRCH_LIMIT
'
For iD_RTS_DAY = 3 To 33 Step 1
If Trim(wsR.Cells(iR_GYO, iD_RTS_DAY)) = "〇" Then
'DB使用
If Trim(wsR.Cells(iR_GYO, R_RTS_USEDB)) = "●" Then
wsR.Cells(iR_GYO, iD_RTS_DAY).Interior.ColorIndex = BACK_COLOR
End If
'リラン可能
If Trim(wsR.Cells(iR_GYO, R_RTS_RERUN)) <> "可" Then
'2023.12.16
'wsR.Cells(iR_GYO, iD_RTS_DAY).Interior.ColorIndex = CHAR_COLOR
wsR.Cells(iR_GYO, iD_RTS_DAY).Font.ColorIndex = CHAR_COLOR
wsR.Cells(iR_GYO, iD_RTS_DAY).Font.Bold = True
End If
End If
Next iD_RTS_DAY
iRCnt = iRCnt + 1
'
iR_GYO = iR_GYO + 1
Loop
If iR_GYO > R_SRCH_LIMIT Then
MsgBox R_SHEET & " 最大検索行を縦超えました" & iR_GYO
SetJobAttentionColor = False
End If
'件数
iRCnt = iR_GYO
SetJobAttentionColor = True
End Function
