Go to Qiita Advent Calendar Top
LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@codebreaker4423

稼働管理Excel　フォーマット作成VBA

Last updated at Posted at 2025-09-21
Sub CreateWorkloadManagementSheet()
    Dim ws As Worksheet
    Dim targetYear As Integer
    Dim targetMonth As Integer
    Dim lastDay As Integer
    Dim i As Integer, j As Integer
    Dim startRow As Integer, startCol As Integer
    
    ' エラーハンドリング
    On Error GoTo ErrorHandler
    
    ' 新しいシートを作成
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = Format(Date, "yyyy年mm月") & "_稼働管理"
    
    ' 基本設定
    targetYear = Year(Date)
    targetMonth = Month(Date)
    lastDay = Day(DateSerial(targetYear, targetMonth + 1, 0))
    startRow = 5
    startCol = 2
    
    ' タイトル設定
    With ws.Range("B2")
        .Value = targetYear & "年" & targetMonth & "月　チーム稼働管理表"
        .Font.Size = 16
        .Font.Bold = True
    End With
    
    ' ヘッダー行の作成
    ' 基本情報列
    ws.Cells(startRow, startCol).Value = "No."
    ws.Cells(startRow, startCol + 1).Value = "氏名"
    ws.Cells(startRow, startCol + 2).Value = "担当"
    
    ' 日付列の作成
    For i = 1 To lastDay
        ' 日付
        ws.Cells(startRow - 1, startCol + 2 + i).Value = i
        ' 曜日
        Dim currentDate As Date
        currentDate = DateSerial(targetYear, targetMonth, i)
        ws.Cells(startRow, startCol + 2 + i).Value = Format(currentDate, "aaa")
        
        ' 週末の色付け
        If Weekday(currentDate) = 1 Then ' 日曜日
            ws.Cells(startRow - 1, startCol + 2 + i).Interior.Color = RGB(255, 200, 200)
            ws.Cells(startRow, startCol + 2 + i).Interior.Color = RGB(255, 200, 200)
        ElseIf Weekday(currentDate) = 7 Then ' 土曜日
            ws.Cells(startRow - 1, startCol + 2 + i).Interior.Color = RGB(200, 200, 255)
            ws.Cells(startRow, startCol + 2 + i).Interior.Color = RGB(200, 200, 255)
        End If
    Next i
    
    ' 集計列
    ws.Cells(startRow, startCol + 2 + lastDay + 1).Value = "予定工数"
    ws.Cells(startRow, startCol + 2 + lastDay + 2).Value = "実績工数"
    ws.Cells(startRow, startCol + 2 + lastDay + 3).Value = "乖離率"
    ws.Cells(startRow, startCol + 2 + lastDay + 4).Value = "備考"
    
    ' サンプルデータの入力（10名分）
    Dim members As Variant
    members = Array("山田太郎", "鈴木花子", "佐藤次郎", "田中美咲", "高橋健一", _
                   "渡辺由美", "伊藤大輔", "中村愛", "小林勇", "加藤綾")
    
    Dim assignments As Variant
    assignments = Array("PM/プロジェクトA", "PL/プロジェクトA", "SE/プロジェクトA", _
                       "SE/プロジェクトB", "PG/プロジェクトB", "PG/プロジェクトC", _
                       "PG/プロジェクトC", "テスター/プロジェクトA", _
                       "デザイナー/プロジェクトB", "SE/プロジェクトC")
    
    For i = 0 To 9
        ws.Cells(startRow + i + 1, startCol).Value = i + 1
        ws.Cells(startRow + i + 1, startCol + 1).Value = members(i)
        ws.Cells(startRow + i + 1, startCol + 2).Value = assignments(i)
        
        ' 予定工数のサンプル値（160時間を基本に）
        ws.Cells(startRow + i + 1, startCol + 2 + lastDay + 1).Value = 160
        
        ' 実績工数の計算式（カレンダーの各マスの合計）
        Dim formulaRange As String
        formulaRange = Range(Cells(startRow + i + 1, startCol + 3), _
                            Cells(startRow + i + 1, startCol + 2 + lastDay)).Address(False, False)
        ws.Cells(startRow + i + 1, startCol + 2 + lastDay + 2).Formula = "=SUM(" & formulaRange & ")"
        
        ' 乖離率の計算式（実績工数 / 予定工数）
        Dim planCell As String, actualCell As String
        planCell = Cells(startRow + i + 1, startCol + 2 + lastDay + 1).Address(False, False)
        actualCell = Cells(startRow + i + 1, startCol + 2 + lastDay + 2).Address(False, False)
        ws.Cells(startRow + i + 1, startCol + 2 + lastDay + 3).Formula = _
            "=IF(" & planCell & "=0,0," & actualCell & "/" & planCell & ")"
    Next i
    
    ' 書式設定
    With ws
        ' 列幅の調整
        .Columns(startCol).ColumnWidth = 5
        .Columns(startCol + 1).ColumnWidth = 12
        .Columns(startCol + 2).ColumnWidth = 20
        
        ' 日付列の幅（時間入力用に少し広めに）
        For i = 1 To lastDay
            .Columns(startCol + 2 + i).ColumnWidth = 4.5
        Next i
        
        ' 集計列の幅
        .Columns(startCol + 2 + lastDay + 1).ColumnWidth = 10
        .Columns(startCol + 2 + lastDay + 2).ColumnWidth = 10
        .Columns(startCol + 2 + lastDay + 3).ColumnWidth = 10
        .Columns(startCol + 2 + lastDay + 4).ColumnWidth = 20
        
        ' 罫線の設定
        Dim dataRange As Range
        Set dataRange = .Range(.Cells(startRow - 1, startCol), _
                              .Cells(startRow + 10, startCol + 2 + lastDay + 4))
        
        With dataRange.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        
        ' ヘッダーの書式設定
        With .Range(.Cells(startRow - 1, startCol), _
                   .Cells(startRow, startCol + 2 + lastDay + 4))
            .Font.Bold = True
            .Interior.Color = RGB(220, 220, 220)
            .HorizontalAlignment = xlCenter
        End With
        
        ' 乖離率の書式設定（パーセント表示）
        .Range(.Cells(startRow + 1, startCol + 2 + lastDay + 3), _
              .Cells(startRow + 10, startCol + 2 + lastDay + 3)).NumberFormat = "0%"
        
        ' 数値セルの中央揃え
        .Range(.Cells(startRow + 1, startCol), _
              .Cells(startRow + 10, startCol)).HorizontalAlignment = xlCenter
        
        ' カレンダー部分の中央揃えと数値書式
        .Range(.Cells(startRow + 1, startCol + 3), _
              .Cells(startRow + 10, startCol + 2 + lastDay)).HorizontalAlignment = xlCenter
        .Range(.Cells(startRow + 1, startCol + 3), _
              .Cells(startRow + 10, startCol + 2 + lastDay)).NumberFormat = "0.0"
        
        ' 予定工数・実績工数の中央揃えと数値書式
        .Range(.Cells(startRow + 1, startCol + 2 + lastDay + 1), _
              .Cells(startRow + 10, startCol + 2 + lastDay + 2)).HorizontalAlignment = xlCenter
        .Range(.Cells(startRow + 1, startCol + 2 + lastDay + 1), _
              .Cells(startRow + 10, startCol + 2 + lastDay + 2)).NumberFormat = "0.0"
        
        ' 乖離率の中央揃え
        .Range(.Cells(startRow + 1, startCol + 2 + lastDay + 3), _
              .Cells(startRow + 10, startCol + 2 + lastDay + 3)).HorizontalAlignment = xlCenter
    End With
    
    ' 条件付き書式の設定（乖離率）
    Dim rateRange As Range
    Set rateRange = ws.Range(ws.Cells(startRow + 1, startCol + 2 + lastDay + 3), _
                            ws.Cells(startRow + 10, startCol + 2 + lastDay + 3))
    
    ' 90%未満は黄色（予定に対して実績が少ない）
    rateRange.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="0.9"
    rateRange.FormatConditions(1).Interior.Color = RGB(255, 255, 200)
    
    ' 110%超は赤色（予定に対して実績が多い）
    rateRange.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="1.1"
    rateRange.FormatConditions(2).Interior.Color = RGB(255, 200, 200)
    
    ' データ検証の追加（時間入力用）
    Dim validationRange As Range
    For i = 1 To 10
        For j = 1 To lastDay
            Set validationRange = ws.Cells(startRow + i, startCol + 2 + j)
            With validationRange.Validation
                .Delete
                .Add Type:=xlValidateDecimal, AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, Formula1:="0", Formula2:="24"
                .IgnoreBlank = True
                .ErrorTitle = "入力エラー"
                .ErrorMessage = "0～24の範囲で時間を入力してください"
            End With
        Next j
    Next i
    
    ' 凡例の追加
    With ws
        .Range("B" & (startRow + 13)).Value = "【入力方法】"
        .Range("B" & (startRow + 14)).Value = "・担当：役割とプロジェクトを「役割/プロジェクト名」形式で入力"
        .Range("B" & (startRow + 15)).Value = "・カレンダー：各日の稼働実績時間を数値で入力（0～24時間）"
        .Range("B" & (startRow + 16)).Value = "・予定工数：月間の稼働予定時間を入力"
        .Range("B" & (startRow + 17)).Value = "・実績工数：カレンダーから自動集計"
        .Range("B" & (startRow + 18)).Value = "・乖離率：実績工数÷予定工数で自動計算"
        
        .Range("B" & (startRow + 20)).Value = "【色分け】"
        .Range("B" & (startRow + 21)).Value = "・乖離率90%未満：黄色（実績が予定を下回る）"
        .Range("B" & (startRow + 22)).Value = "・乖離率110%超：赤色（実績が予定を上回る）"
        .Range("B" & (startRow + 23)).Value = "・土曜日：青色、日曜日：赤色"
    End With
    
    ' 合計行の追加
    Dim totalRow As Integer
    totalRow = startRow + 11
    
    With ws
        .Cells(totalRow, startCol + 1).Value = "合計"
        .Cells(totalRow, startCol + 1).Font.Bold = True
        
        ' 予定工数の合計
        Dim planSumRange As String
        planSumRange = Range(Cells(startRow + 1, startCol + 2 + lastDay + 1), _
                           Cells(startRow + 10, startCol + 2 + lastDay + 1)).Address(False, False)
        .Cells(totalRow, startCol + 2 + lastDay + 1).Formula = "=SUM(" & planSumRange & ")"
        
        ' 実績工数の合計
        Dim actualSumRange As String
        actualSumRange = Range(Cells(startRow + 1, startCol + 2 + lastDay + 2), _
                             Cells(startRow + 10, startCol + 2 + lastDay + 2)).Address(False, False)
        .Cells(totalRow, startCol + 2 + lastDay + 2).Formula = "=SUM(" & actualSumRange & ")"
        
        ' 合計行の書式設定
        With .Range(.Cells(totalRow, startCol), .Cells(totalRow, startCol + 2 + lastDay + 4))
            .Interior.Color = RGB(240, 240, 240)
            .Font.Bold = True
            .Borders(xlEdgeTop).LineStyle = xlDouble
        End With
    End With
    
    ' ウィンドウ枠の固定
    ws.Activate
    ws.Cells(startRow + 1, startCol + 3).Select
    ActiveWindow.FreezePanes = True
    
    ' A1セルを選択
    ws.Range("A1").Select
    
    MsgBox "稼働管理表を作成しました。" & vbCrLf & _
           "シート名: " & ws.Name & vbCrLf & vbCrLf & _
           "カレンダーの各マスに稼働実績時間を入力してください。", _
           vbInformation, "作成完了"
    
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical, "エラー"
End Sub

' 週次集計を行うサブプロシージャ
Sub CalculateWeeklyStatistics()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim statsRow As Long
    Dim startCol As Integer
    Dim targetYear As Integer
    Dim targetMonth As Integer
    Dim lastDay As Integer
    Dim weekNum As Integer
    Dim i As Integer
    
    On Error Resume Next
    Set ws = ActiveSheet
    startCol = 2
    
    ' データの最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, startCol + 1).End(xlUp).Row
    statsRow = lastRow + 5
    
    ' 年月を取得
    targetYear = Year(Date)
    targetMonth = Month(Date)
    lastDay = Day(DateSerial(targetYear, targetMonth + 1, 0))
    
    ' 集計タイトル
    ws.Cells(statsRow, startCol).Value = "【週次集計】"
    ws.Cells(statsRow, startCol).Font.Bold = True
    ws.Cells(statsRow, startCol).Font.Size = 12
    
    ' 週ごとの実績を集計
    statsRow = statsRow + 1
    ws.Cells(statsRow, startCol).Value = "週"
    ws.Cells(statsRow, startCol + 1).Value = "期間"
    ws.Cells(statsRow, startCol + 2).Value = "チーム合計実績"
    
    ' ヘッダーの書式設定
    With ws.Range(ws.Cells(statsRow, startCol), ws.Cells(statsRow, startCol + 2))
        .Font.Bold = True
        .Interior.Color = RGB(220, 220, 220)
        .Borders.LineStyle = xlContinuous
    End With
    
    MsgBox "週次集計を追加しました。", vbInformation, "集計完了"
End Sub
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?