ExcelのデータからPDFレポートを生成する次のコードがあります。レポートは、必要な時間数に基づいて生成する必要があります。時間数は特定の日付（会計年度の終わり）を過ぎることはできません。それは、必要な合計時間を要し、一定量のレポートを生成します。レポートには、レポートあたり200時間の上限があります。関数が終了していません
たとえば、合計時間が524の場合、3つのレポートが生成される必要があります.2つのレポートは200時間、1つのレポートは124です。合計時間が終了日を過ぎると予測されない限り、この例の終了日は6/30/2016です。
たとえば、人が2時間働いていると予測し、レポートの開始日が6/11/2016である場合、200時間のレポートは100日に変換され、終了日は論理的には2011年9月19日です。勅令による終了日は6/30/2016でなければならないことを除けば、19日の報告に過ぎない。
WritePDFforms関数はこの情報を取り込んでPDFに変換します。それは問題がどこにあるのではない。
問題は、必要な合計時間が524で、開始日が2015/11/24であることです。最初のレポートは200時間、つまり100日間で、2013年3月3日に終了するはずです。 2番目のレポートは200時間、つまり100日で、2011年6月6日に終了します。 3番目のレポートは38時間、つまり19日間で、2016年6月30日に終了します。
目標は、特定のレポートの開始日をWritePDFforms関数の各繰り返しで保存することです。たとえば、最初のレポートには2015年11月24日が必要です。 2番目には2016年3月3日が必要です。 3番目には2011年6月11日が必要です。そのレポートは、会計年度の終わりまたは6/30に終了するため、停止する必要があります。
コードの書き方は、ブールチェックを実行し、extStartDate変数を更新することです。最終的にはfalseを返しますが、extStartDateは2016年6月30日に更新され、最終的に保存されます。私はそれが最後の時間を実行することを望んでいない。私はプログラムが最終日になる前にカットしたいと思っていますが、A）レポートが財政的カットオフに達したか、またはB）レポートする必要がある時間がもう1つあるため、最後の時間です。
合計で、checkExtensionNeed関数は1回すぎます。前回のcheckExtensionNeedでは、変数extStartDateが更新されます。私はそれが最後の時間を反復することを望んでいません、そして、それが最後の時間を反復するならば、私はextStartDateが更新されることを望んでいません。
Option Explicit
Dim totalHoursNeeded As Long
Dim extStartDate As Date
Dim lastBillableDate As Date
Dim daysRemaining As Long
Dim hoursPerDay As Long
Dim hoursColumn As Long
Dim dateLastApproved As Date
Dim dateLastWritten As Date
Dim startDate As Date
Dim amountLastApproved As Long
Dim amountLastWritten As Long
Dim extensionSheet As Worksheet
Dim totalHoursInExt As Long
'preliminary subroutine, calls writepdfforms
'called from the double click method
'shName = worksheet that gets the double click
'RowNumber = row of the double clicked cell
Public Sub FillSelectedForms(ShName As Worksheet, RowNumber As Long)
Dim cell As Range, wks As Worksheet, Templ As ListObject, ExitLine As Label
Dim i As Long
Set extensionSheet = ThisWorkbook.Worksheets("Extensions")
'get template list
Set wks = ThisWorkbook.Worksheets("Templates List")
Set Templ = wks.ListObjects(1)
If Templ.ListColumns(1).DataBodyRange Is Nothing Then
MsgBox "No data found in Templates List", vbInformation, "Missing Data"
GoTo ExitLine
End If
'databodyrange = first column in the data (not header) cell 1
Set cell = Templ.ListColumns(1).DataBodyRange.Cells(1)
For i = 1 To extensionSheet.Range("G1").End(xlToRight).column
If InStr(1, extensionSheet.Cells(1, i).Text, "Average number of hours") > 0 Then
hoursPerDay = extensionSheet.Cells(RowNumber, i)/7
ElseIf InStr(1, extensionSheet.Cells(1, i).Text, "73 - Total Requested Hours") > 0 Then
hoursColumn = i
Else
End If
Next i
'first find total amount of hours needed
totalHoursNeeded = Worksheets("Summary").Cells(RowNumber, 12)
'do while
Do While (checkExtensionNeed(RowNumber)) = True
' MsgBox ("On iteration " & i & " Total Hours in Extension is " & totalHoursInExt & " Last Date Written is " & dateLastWritten)
' i = i + 1
If totalHoursNeeded >= 200 Then
'would a 200 hour extension go past the lastBillableDate?
If DateAdd("d", totalHoursInExt/hoursPerDay, extStartDate) > lastBillableDate Then
'go up to the last billable date and not further
totalHoursInExt = CLng(daysRemaining/hoursPerDay)
Else
totalHoursInExt = 200
End If
extensionSheet.Cells(RowNumber, hoursColumn) = totalHoursInExt
Else
'if there is less than 200 hours remaining AND would a full extension go past the last billable date
If DateAdd("d", totalHoursInExt/hoursPerDay, extStartDate) > lastBillableDate Then
totalHoursInExt = CLng(daysRemaining * hoursPerDay)
Else
totalHoursInExt = totalHoursNeeded
End If
extensionSheet.Cells(RowNumber, hoursColumn) = totalHoursInExt
End If
WritePDFForms ShName.Name, RowNumber, cell, cell.Offset(0, 1)
extensionSheet.Cells(RowNumber, hoursColumn + 1) = DateAdd("d", totalHoursInExt/hoursPerDay, extStartDate)
totalHoursNeeded = totalHoursNeeded - totalHoursInExt
Loop
MsgBox (extensionSheet.Cells(RowNumber, hoursColumn + 1))
ExitLine:
Set Templ = Nothing
Set wks = Nothing
Set cell = Nothing
End Sub
Public Function checkExtensionNeed(Row As Long)
' Find start date of Extension
' Find year/wage pair
' Find total number of hours needed in extension
Dim summarySheet As Worksheet, extensionSheet As Worksheet, i As Long
Dim j As Long
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set extensionSheet = ThisWorkbook.Worksheets("Extensions")
'find dates for comparison
For i = 1 To extensionSheet.Range("A1").End(xlToRight).column
'find date of last approved extension
If InStr(1, summarySheet.Cells(1, i), "Year 1 Most Recent Extension Approval Date") > 0 Then
dateLastApproved = summarySheet.Cells(Row, i)
'find date of last written extension
ElseIf InStr(1, extensionSheet.Cells(1, i), "Start Date (To be Calculcated)") > 0 Then
dateLastWritten = extensionSheet.Cells(Row, i)
'find date of start in Project Sweep
ElseIf InStr(1, summarySheet.Cells(1, i), "Year 1 Start Date") > 0 Then
startDate = summarySheet.Cells(Row, i)
ElseIf InStr(1, summarySheet.Cells(1, i), "Year 1 Most Recent Extension Approval Amount") > 0 Then
amountLastApproved = summarySheet.Cells(Row, i)
ElseIf InStr(1, extensionSheet.Cells(1, i), "Total Requested Hours") > 0 Then
amountLastWritten = extensionSheet.Cells(Row, i)
End If
Next i
If dateLastApproved > dateLastWritten Then
extStartDate = DateAdd("d", amountLastApproved/hoursPerDay, dateLastApproved)
extensionSheet.Cells(Row, hoursColumn + 1) = extStartDate
Else
extStartDate = dateLastWritten
'extensionSheet.Cells(Row, hoursColumn + 1) = dateLastWritten
End If
lastBillableDate = DateAdd("d", 365, startDate)
daysRemaining = lastBillableDate - extStartDate
If extStartDate < lastBillableDate And totalHoursNeeded > 0 Then
checkExtensionNeed = True
Else
checkExtensionNeed = False
End If
End Function