週間進捗報告書生成

Option Explicit

'VSSのiniファイルの場所
Private SRCSAFE_INI As String


'機能名：　週間進捗報告書生成
'作成日：　2010/12/25
'
'
Sub Macro1()
    'On Error GoTo ErrorHandler

    '設定値取得
    Call GetWeekReport
   
    MsgBox "週間進捗報告書生成成功。"
   
End Sub


Private Sub GetWeekReport()
    Dim wbs As Worksheet
    Set wbs = ThisWorkbook.Worksheets("進捗管理")

    Dim i As Integer
    Dim count As Integer
    Dim tmpcount As Integer
    Dim beginTmpcount As Integer
    Dim beginCount As Integer
    Dim sum As Integer
    Dim complete As Integer
    Dim weeksum As Integer
    Dim weekcomplete As Integer
    Dim remainsum As Integer
    Dim remaincomplete As Integer
   
    Dim weekStartDate As Date
    Dim weekEndDate As Date
    Dim tojiDate As Date
    tojiDate = CDate("2010/12/30")
   
    weekStartDate = tojiDate - Weekday(tojiDate, 2) + 1
    weekEndDate = tojiDate + 5 - Weekday(tojiDate, 2)
   
    MsgBox weekStartDate & "-" & weekEndDate
    Dim weekReport As Worksheet
    Dim weekReportName As String
    weekReportName = "週間進捗(" & Format(weekStartDate, "yyyymmdd") & "-" & Format(weekEndDate, "yyyymmdd") & ")"
   
    If IsShtExist(weekReportName) Then
        Set weekReport = ThisWorkbook.Worksheets(weekReportName)
    Else
        Set weekReport = Worksheets.Add(, after:=Worksheets(Worksheets.count))
        weekReport.Name = weekReportName
    End If
  
   
    Dim lastGamenName As String
    Dim gamenName As String
   
    Dim lastEndDate As String
    Dim endDate As String
    Dim lastStartDate As String
    Dim startDate As String
    Dim lastRealEndDate As String
    Dim realEndDate As String
   
    count = 15
    weeksum = 0
    weekcomplete = 0
   
    sum = 0
    complete = 0
   
    beginCount = count
    
    '今週遅延タスク->ヘッダ設定
    weekReport.Cells(beginCount + 2, "B") = "今週遅延タスク"
    weekReport.Cells(beginCount + 3, "B") = "分類"
    weekReport.Cells(beginCount + 3, "C") = "今週遅延タスク"
    weekReport.Cells(beginCount + 3, "D") = "遅延理由"
    weekReport.Range("D" & (beginCount + 3), "E" & (beginCount + 3)).MergeCells = True
    weekReport.Cells(beginCount + 3, "F") = "リカバリ対策"

    '基本設計書進捗統計
    tmpcount = 1
    For i = 3 To 45
        gamenName = wbs.Cells(i, "C")
        If gamenName <> "" Then
            If wbs.Cells(i, "E") <> "" Then
                startDate = wbs.Cells(i, "F")
                If startDate = "" Then
                    startDate = lastStartDate
                Else
                    lastStartDate = startDate
                End If
               
                endDate = wbs.Cells(i, "G")
                If endDate = "" Then
                    endDate = lastEndDate
                Else
                    lastEndDate = endDate
                End If
               
                realEndDate = wbs.Cells(i, "I")
               
                '今週完成すべきタスク
                If (endDate <= weekEndDate And endDate >= weekStartDate) Then
                    If (count - beginCount) Mod 4 = 0 Then
                        Rows(((count - beginCount) \ 4 + beginCount) & ":" & ((count - beginCount) \ 4 + beginCount)).Select
                        Selection.Insert Shift:=xlDown
                    End If
                    weekReport.Cells((count - beginCount) \ 4 + beginCount, (count - beginCount) Mod 4 + 3).Select
                    Selection = gamenName
                    If wbs.Cells(i, "J") = 1 Then
                        Selection.Interior.ColorIndex = 43
                        weekcomplete = weekcomplete + 1
                    Else
                        Selection.Interior.ColorIndex = 0
                        '今週遅延タスク
                        weekReport.Cells(beginCount + 4 + (count - beginCount) \ 4 + tmpcount, "C") = gamenName
                        tmpcount = tmpcount + 1
                    End If
                    count = count + 1
                    weeksum = weeksum + 1
                '今週初期残項目数
                ElseIf wbs.Cells(i, "E") <> "" Then
                    If realEndDate = "" Then
                        If (count - beginCount) Mod 4 = 0 Then
                            Rows(((count - beginCount) \ 4 + beginCount) & ":" & ((count - beginCount) \ 4 + beginCount)).Select
                            Selection.Insert Shift:=xlDown
                            Selection.Interior.ColorIndex = 0
                        End If
                        weekReport.Cells((count - beginCount) \ 4 + beginCount, (count - beginCount) Mod 4 + 3).Select
                        Selection = gamenName
                        Selection.Interior.ColorIndex = 0
                        weekReport.Cells(beginCount + 4 + (count - beginCount) \ 4 + tmpcount, "C") = gamenName
                        tmpcount = tmpcount + 1
                        count = count + 1
                        remainsum = remainsum + 1
                    ElseIf (realEndDate <= weekEndDate And realEndDate >= weekStartDate) Then
                        If (count - beginCount) Mod 4 = 0 Then
                            Rows(((count - beginCount) \ 4 + beginCount) & ":" & ((count - beginCount) \ 4 + beginCount)).Select
                            Selection.Insert Shift:=xlDown
                        End If
                        weekReport.Cells((count - beginCount) \ 4 + beginCount, (count - beginCount) Mod 4 + 3).Select
                        Selection = gamenName
                        If wbs.Cells(i, "J") = 1 Then
                            Selection.Interior.ColorIndex = 43
                            remaincomplete = remaincomplete + 1
                        '今週遅延タスク
                        Else
                            Selection.Interior.ColorIndex = 0
                        End If
                        count = count + 1
                        remainsum = remainsum + 1
                    End If
                End If
             
                If (endDate <= weekEndDate) Then
                    If wbs.Cells(i, "J") = 1 Then
                         complete = complete + 1
                    End If
                End If
                sum = sum + 1
            End If
        End If
    Next i
   
    If beginCount <> count Then
        weekReport.Cells(beginCount, "B") = "基本設計書"
        weekReport.Range("B" & beginCount, "B" & ((count - beginCount) \ 4 + beginCount)).MergeCells = True
        weekReport.Range("B" & beginCount, "B" & ((count - beginCount) \ 4 + beginCount)).VerticalAlignment = Excel.xlCenter
       
        weekReport.Cells(beginCount + 5 + (count - beginCount) \ 4, "B") = "基本設計書"
        weekReport.Range("B" & beginCount + 5 + (count - beginCount) \ 4, "B" & (beginCount + 3 + (count - beginCount) \ 4 + tmpcount)).MergeCells = True
        weekReport.Range("B" & beginCount + 5 + (count - beginCount) \ 4, "B" & (beginCount + 3 + (count - beginCount) \ 4 + tmpcount)).VerticalAlignment = Excel.xlCenter
    End If
   
    '詳細設計書進捗統計
    count = (count - beginCount) \ 4 + beginCount + 2
    beginCount = count
    beginTmpcount = tmpcount
    For i = 3 To 45
        gamenName = wbs.Cells(i, "C")
        If gamenName <> "" Then
            startDate = wbs.Cells(i, "M")
            If startDate <> "" Then
                endDate = wbs.Cells(i, "N")
                If endDate = "" Then
                    endDate = lastEndDate
                Else
                    lastEndDate = endDate
                End If
               
                'MsgBox endDate
                If (endDate <= weekEndDate And endDate >= weekStartDate) Then
                    'wbs.Range("B" & i, "C" & i).Copy Destination:=weekReport.Range("B" & count, "C" & count)
                    'weekReport.Range("F" & count).NumberFormatLocal = "yyyy-mm-dd"
                    'weekReport.Cells(count, "H") = Format(wbs.Cells(i, "Q"), "0%")
                    'MsgBox (count - beginCount) / 4 + 15 & gamenName
                    If (count - beginCount) Mod 4 = 0 Then
                        Rows(((count - beginCount) \ 4 + beginCount) & ":" & ((count - beginCount) \ 4 + beginCount)).Select
                        Selection.Insert Shift:=xlDown
                    End If
                    '今週完成すべきタスク
                    weekReport.Cells((count - beginCount) \ 4 + beginCount, (count - beginCount) Mod 4 + 3).Select
                    Selection = gamenName
                    If wbs.Cells(i, "Q") = 1 Then
                        Selection.Interior.ColorIndex = 43
                        weekcomplete = weekcomplete + 1
                    Else
                        '今週遅延タスク
                        Selection.Interior.ColorIndex = 0
                        weekReport.Cells(beginCount + 3 + (count - beginCount) \ 4 + tmpcount, "C") = gamenName
                        tmpcount = tmpcount + 1
                    End If
                    count = count + 1
                    weeksum = weeksum + 1
                End If
               
                If (endDate <= weekEndDate) Then
                    If wbs.Cells(i, "Q") = 1 Then
                        complete = complete + 1
                    End If
                End If
                sum = sum + 1
            End If
        End If
    Next i
    If beginCount <> count Then
        weekReport.Cells(beginCount, "B") = "詳細設計書"
        weekReport.Range("B" & beginCount, "B" & ((count - beginCount) \ 4 + beginCount - 1)).MergeCells = True
        weekReport.Range("B" & beginCount, "B" & ((count - beginCount) \ 4 + beginCount - 1)).VerticalAlignment = Excel.xlCenter
       
        weekReport.Cells(beginCount + 3 + (count - beginCount) \ 4 + (tmpcount - beginTmpcount), "B") = "詳細設計書"
        weekReport.Range("B" & beginCount + 2 + (count - beginCount) \ 4 + (tmpcount - beginTmpcount), "B" & (beginCount + 1 + (count - beginCount) \ 4 + tmpcount)).MergeCells = True
        weekReport.Range("B" & beginCount + 2 + (count - beginCount) \ 4 + (tmpcount - beginTmpcount), "B" & (beginCount + 1 + (count - beginCount) \ 4 + tmpcount)).VerticalAlignment = Excel.xlCenter
    End If
   
   
    '共通設定
    weekReport.Cells(3, "C") = remainsum
    weekReport.Cells(6, "C") = remaincomplete
   
    weekReport.Cells(3, "D") = weeksum
    weekReport.Cells(6, "D") = weekcomplete
   

   
    weekReport.Cells(9, "C") = complete
    'weekReport.Cells(3, "E") = sum
   
    weekReport.Rows.AutoFit
    weekReport.Columns.AutoFit
End Sub

Function IsShtExist(ShtName As String) As Boolean
    On Error Resume Next
    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets(ShtName)
    If Not Sht Is Nothing Then IsShtExist = True
End Function