Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4713 / 76732

←次へ　｜　前へ→


	【77635】Re:【Excel】経理の表について

β - 15/11/13(金) 19:46 -


	引用なし

	パスワード

▼かおさん：

今後はルールを守っていただくとして。

レイアウト、不明なところもありますが、
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

2 hits

▼

【77633】【Excel】経理の表について かお 15/11/13(金) 17:30