Excel VBAや関数で数字を自動で整理したい

Question

添付の画像のように1行10分として10分間の内訳がC～G列まであり、H列に行の合計があります。
本来なら手を加えなくても合計は600秒になるはずですが、
元データが「開始時間から何秒間」というデータの取り方をしている為
600秒以上が内訳に出てきてしまいます。（8:40のD列など)

これまでは、600以上の場合は600で区切りはみ出た分を1つ下の行に移すという作業を手作業でやっていましたが、数が増えてきたので自動化したいです。
VBA、関数何でも構いませんが自動で計算してくれる方法はないでしょうか？

VBAの場合は簡単に解説を付けていただけると大変助かります。
よろしくお願いします。

WindFaller · Accepted Answer

それは、解決していた問題だと思ったのですが。
こちらでやってみますと、No.6 の修正版で以下のようになっています。
赤の部分は、今は、考えていません。

WindFaller · Answer

何度もすみません。
前回お書きしたように、最後の行の部分を削除してください。

If rng(1, 1).Value = 0 Then
　　 MsgBox rng(1, 1).Address(0, 0) & " は処理できません。中止します。", vbCritical
　　rng(1, 1).Select
　　End
　 End If
最後の行から、5行を削除して、行かのようになれば良いです。

削除後の画面
　Else
　　　buf = rng(1, k).Value
　　　rng(1, k).Value = 0　'先送り
　　　rng(2, k).Value = rng(2, k).Value + buf
　　　buf = 0
　　End If
　End If
　diff = 0
End Function

表を試してみると、辻褄が合うようになっているのでしょうか？

WindFaller · Answer

#4で書いたとおり、相手の考えを先回りしたマクロコードというものは、失敗していました。

画像のタイトルをみて、なんとなく意味は分かりました。
>項目を同じにしたいですが可能でしょうか？
もちろんですが、ただ、私は分かっていない点があります。

勝手な考えかと思いますが、
直感的ですが、繰り越し作業で、C列の値が0になる場合は、エラーということにしました。
最後の行は、600秒に足らない場合もあるというオプションを入れました。

これは、ある一定期間(約100件）の様子見が必要な気がします。
未だ、全体の理解しているわけではないことをおことわりしておきます。

なお、コード全体を全面的にやり直しました。
場合によっては、これは、無限ループに入る恐れがありますが、その場合は、ESCを何度か押していただければ、マクロは止まります。理由は、1箇所の修正だけで済まない可能性を考えたからです。

'//
Sub Target600sec()
''modified4
　Dim x As Long, i As Long
　Dim a As Long, b As Long
　Dim Lastrow As Long
　Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
　
　x = 2 '開始行スタート
　a = 3 '開始列
　b = 7 '終了列
　Do
　　If Abs(Application.Sum(Range(Cells(x, a), Cells(x, b))) - 600) > 5 Then
　　　get600 Range(Cells(x, a), Cells(x, b))
　　End If
　　If Abs(Application.Sum(Range(Cells(x, a), Cells(x, b))) - 600) <= 5 Then
　　　x = x + 1
　　　DoEvents
　　End If
　Loop Until x = Lastrow Or Cells(x, b + 1).Value <= 0　'合計列
　For i = a To b
　　If Cells(x, i).Value < 0 Then
　　　Cells(x - 1, i).Value = Cells(x - 1, i).Value + Cells(x, i).Value
　　　Cells(x, i).Value = 0
　　End If
　Next
End Sub
Function get600(rng As Range)
　Dim ttl As Double
　Dim c As Variant, i As Long, k As Long
　Dim diff As Double
　Dim cmax As Double
　Dim buf
　ttl = Application.Sum(rng)
　For i = 1 To rng.Columns.Count
　　If cmax < rng(1, i).Value Then
　　　cmax = rng(1, i).Value　'最大値を見つける
　　　k = i
　　End If
　Next
　If Abs(ttl - 600) > 5 Then
　　diff = ttl - 600
　　If cmax - diff > 0 Then
　　　rng(1, k).Value = rng(1, k).Value - diff
　　　rng(2, k).Value = rng(2, k).Value + diff
　　Else
　　　buf = rng(1, k).Value
　　　rng(1, k).Value = 0　'先送り
　　　rng(2, k).Value = rng(2, k).Value + buf
　　　buf = 0
　　End If
　End If
　diff = 0
　If rng(1, 1).Value = 0 Then
　　 MsgBox rng(1, 1).Address(0, 0) & " は処理できません。中止します。", vbCritical
　　rng(1, 1).Select
　　End
　 End If
End Function

エラーがうっとうしければ、以下のように、コメントブロックでもつけてください。
削除も可能です。
'//
　' If rng(1, 1).Value = 0 Then
　'　　MsgBox rng(1, 1).Address(0, 0) & " は処理できません。中止します。", vbCritical
　'　 rng(1, 1).Select
　'　 End
　'　End If

WindFaller · Answer

>赤字セルが下に繰り越されることになりますがこちらも対応していますでしょうか？それは範囲を広げればよいことですが、 10:40　603　0　0　0 　　　↓ 10:40　600　0　0　0 の部分は、こちらが意図したことではなかったのですが、数値が変更されてしまいました。つまり、以下のマクロは、合計欄は別ですが、数値の多いところから引くという原則で成り立っています。ある程度、想定の範囲もあるのですが、未だにしっくりしないところもあり、様々なデータを当たってみないと、まだ、見えていない部分があります。 '//標準モジュール Sub Target600sec() 　''modified1 　Dim i As Long, j As Long, k As Long 　Dim cmax As Long 　Dim diff As Long 　Const RATIO As Double = 1.005　'誤差±0.5% 　For i = 2 To Cells(Rows.Count, 8).End(xlUp).Row 　　If Cells(i, 8).Value > Int(600 * RATIO) Or _ 　　　 Cells(i, 8).Value < Int(600 / RATIO) Then 　　　diff = Cells(i, 8).Value - 600 　　End If 　　'D列以外にも範囲を広げる　　 cmax = Application.Max(Cells(i, 3).Resize(, 5)) 　　 j = Application.Match(cmax, Cells(i, 3).Resize(, 5), 0) + 2 　　　If k = 0 Then k = j 　　If diff > 0 Then 　　　Cells(i, j).Value = Cells(i, j).Value - diff 　　　Cells(i + 1, k).Value = Cells(i + 1, k).Value + diff 　　ElseIf diff < 0 Then 　　　'補完(符合が逆になる）　　　If Cells(i - 1, 8).Value > 600 Then 　　　　Cells(i - 1, j).Value = Cells(i - 1, j).Value + diff 　　　　Cells(i, j).Value = Cells(i, j).Value - diff 　　　End If 　　End If 　　k = j 　　diff = 0 　Next End Sub

WindFaller · Answer

こんにちは。

>600付近(感覚ですが±5)　
というと、0.8%　なりますが、今は、誤差の範囲は0.5%ぐらいにしてみました。

ただ、今までの私のジンクスですと、相手の考えを先回りしたマクロコードというものは、だいたい失敗していることが多いのです。それは、誤差の範囲をクリアしているのなら、それを戻る必要がないのに、次行で不足していて、両方とも誤差の範囲なら、前の行から少し秒をいただくという補完をしているのが想像出来てしまったからです。

例：
605
594
　↓
600
599
となることです。懸念材料として、600平均で埋まらない所も出てくるような気がしました。

せっかく、#1,2 の方も回答しているので、どんな回答になるか、待ってみても損はないと思います。

'//標準モジュール
Sub Target600sec()
　Dim i As Long
　Dim diff As Long
　Const RATIO As Double = 1.005 '誤差±0.5%
　For i = 2 To Cells(Rows.Count, 8).End(xlUp).Row
　　If Cells(i, 8).Value > Int(600 * RATIO) Or _
　　Cells(i, 8).Value < Int(600 / RATIO) Then
　　　diff = Cells(i, 8).Value - 600
　　End If
　　
　　If diff > 0 Then
　　　Cells(i, 4).Value = Cells(i, 4).Value - diff
　　　Cells(i + 1, 4).Value = Cells(i + 1, 4).Value + diff
　　ElseIf diff < 0 Then
　　　'補完(符合が逆になる）
　　If Cells(i - 1, 8).Value > 600 Then
　　　Cells(i - 1, 4).Value = Cells(i - 1, 4).Value + diff
　　　Cells(i, 4).Value = Cells(i, 4).Value - diff
　　 End If
　　End If
　　diff = 0
　Next
End Sub

'結果は以下のとおりです。

WindFaller · Answer

本来の表のあり方を書いてくれたらよく分かったけれども、言葉だけの説明ですと、よくわかりませんね。D列(B)だけで処理するとは思えませんが、文章からですと、画像のようになることを想像してしまいました。実際、#2さんの表では、私のやり方ではうまくいかなくなります。

8:40| 284, 799 ....1083   (483 余り）
8:50| 101, 21 .......122
　　　　↓
8:40| 284, 316 ....．600
8:50| 101, 504 .......605　(5余り)

と順繰りにトータル600にしていくことかと思いました。
多い場合は、B列で調整し、足りない場合は、G列で調整しています。
したがって、画像では以下のようになると思いました。(マクロで作られた表です）

GooUserラック · Answer

No.1 について

質問が判りにくかったようです。下図の「元」の場合は「①」「②」のどちらになりますか？

GooUserラック · Answer

多分600を超えた列の下の行に溢れた分が追加されると思うのですが、溢れた列の後の列に数字が有ったときは次のどちらにするのでしょうか？
・まとめて最初に溢れた列の次の行に追加する。
・あふれた列以降はそれぞれの列の次の行に追加する。

Excel VBAや関数で数字を自動で整理したい

それは、解決していた問題だと思ったのですが。

何度もすみません。

#4で書いたとおり、相手の考えを先回りしたマクロコードというものは、失敗していました。

>赤字セルが下に繰り越されることになりますがこちらも対応していますでしょうか？

こんにちは。

本来の表のあり方を書いてくれたらよく分かったけれども、言葉だけの説明ですと、よくわかりませんね。

No.1 について

多分600を超えた列の下の行に溢れた分が追加されると思うのですが、溢れた列の後の列に数字が有ったときは次のどちらにするのでしょうか？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング