| |
▼かお さん：
今後はルールを守っていただくとして。
レイアウト、不明なところもありますが、
A列が案件、B列が開始日、C列が終了日、D列から右に月（データとしては日付型。表示形式で m月になっている）
１行目がタイトル行、２行目からデータということにしています。
按分計算の結果でてきた計算誤差については最終月で調整しています。
Sub Test()
Dim c As Range
Dim dic As Object
Dim v As Variant
Dim n As Long
Dim x As Long
Dim d As Date
Dim f As Long
Dim t As Long
Dim days As Long
Dim tot As Long
Dim amt As Long
Set dic = CreateObject("Scripting.Dictionary")
With Range("A1").CurrentRegion
ReDim v(1 To .Rows.Count - 1, 1 To .Columns.Count - 4)
For Each c In .Rows(1).Offset(, 4).Resize(, .Columns.Count - 4).Cells
dic(Format(c.Value, "yyyymm")) = dic.Count + 1
Next
For Each c In .Columns(1).Offset(1).Resize(.Rows.Count - 1).Cells
tot = 0
days = DateDiff("d", c.Offset(, 1).Value, c.Offset(, 2).Value) + 1
n = DateDiff("m", c.Offset(, 1).Value, c.Offset(, 2).Value) + 1
d = c.Offset(, 1).Value
For x = 1 To n
If n = 1 Then
f = Day(c.Offset(, 1).Value)
t = Day(c.Offset(, 2).Value)
Else
If x = 1 Then
f = Day(c.Offset(, 1).Value)
t = Day(DateSerial(Year(c.Offset(, 1).Value), Month(c.Offset(, 1).Value) + 1, 0))
ElseIf x = n Then
f = 1
t = Day(c.Offset(, 2).Value)
Else
f = 1
t = Day(DateSerial(Year(d), Month(d) + 1, 0))
End If
End If
amt = c.Offset(, 3).Value * (t - f + 1) / days
If x = n Then amt = c.Offset(, 3).Value - tot
tot = tot + amt
If dic.exists(Format(d, "yyyymm")) Then
v(c.Row - 1, dic(Format(d, "yyyymm"))) = amt
End If
d = DateAdd("m", 1, d)
Next
Next
End With
Range("E2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
