エクセル マクロ VBAでスケジュールの時間に合わせてセルを結合したい

1週間のタイムスケジュールを作成しています。

添付の図1のように、
A列には時間列(5分間隔）があります。A1（8：00)～A159（21：00）

B列には開始時間、C列には終了時間、D列には内容があり
同じように1週間分のデータが、Z列、AA列、AB列までそれぞれ入っています。

現在は1件ずつ、開始時間から終了時間までのセルの結合を繰り返して
図2のようなスケジュールを作成しています。

5分はセル結合しない
10分はセルを2つ結合
15分はセルを3つ結合
　～
30分はセルを6つ結合
　～
60分はセルを12個結合
　～
180分はセルを36個結合、のように
開始から終了の時間に合わせて、
1週間分のそれぞれの内容のセルを結合することは可能でしょうか？

VBAで解決する良い方法がありましたら教えていただきたいです。
よろしくお願いいたします。

質問者からの補足コメント

• 皆さまご回答ありがとうございます。
  
  補足ですが、
  現在手入力ですがC列の終了時刻が次のイベントに重なってしまうことはありません。(重ならない様に確認しています)
  
  現在は1枚のシートで作業しておりますが、
  皆さまの回答を参考にいたしますと、
  予定を入力するシートと結果を反映するシートが別の方が良いようですが、それも可能でしょうか？
  
  合わせてよろしくお願いいたします。

    補足日時：2017/03/11 15:59

• No.12　マクロ実行で、シートにコピー後このようになります。
  よろしくお願いいたします。

  
    補足日時：2017/03/12 18:39

• No.1３
  
  デバッグの仕方が間違っていたらスイマセン。
  
  エクセルのシートでマクロ実行しますと
  上の画像の黄色の位置まで進み、
  中央の画像となります。
  
  マクロソースの画面で実行しますと
  同じく上の画像の黄色の位置まで進み、
  下の画像となります。
  
  力量がなく何度も大変申し訳ありませんがよろしくお願いいたします。

  
    補足日時：2017/03/12 22:43

• 上記の補足ですが
  表記NO.13ではなくNo.15
  の間違いでしたスイマセン。
  
  画像も小さく申し訳ありません。
  下の画像は
  エラー 1004 「アプリケーション定義またはオブジェクト定義のエラーです。」
  と表示されています。
  よろしくお願いいたします。

    補足日時：2017/03/12 23:04

No.11 回答者： yokomaya 回答日時： 2017/03/12 03:53

イベントはちょっと面白いでしょ。

ただ特有の難しさもあって、イベントを発生させてしまう構文が混じると予期しないジャンプをしてしまうので、ステップ実行やブレークポイントを使い込む必要があります。
Mergeの所が範囲を決めてるから.Mergeを次の行に移して、前に
withを使うと、その範囲を繰り返し使えます。例えば囲む罫線とか、色つけとかね。
コピペが何を指すか、分からないけど、コピペも前述のイベントを引き起こす操作なのでご注意を。
また不明な事あれば訊いてください。

この回答へのお礼

yokomayaさま
ご回答ありがとうございます。

Worksheetのイベントプロシージャーの機能は
今後も是非使っていこうと思います。

またアドバイスを参考に、色々と挑戦してみたいと思います。
また何かありましたら、その節はご教授よろしくお願い致します。
本当にありがとうございました。

お礼日時：2017/03/12 07:19

No.10 回答者： tatsu99 回答日時： 2017/03/11 23:15

>皆さまの回答を参考にいたしますと、

>予定を入力するシートと結果を反映するシートが別の方が良いようですが、それも可能でしょうか？
可能です。但し、その場合、予定を入力するシートと結果を反映するシートのシート名を予め、決めておいたほうが良いでしょう。
１例です。
予定を入力するシートのシート名：予定表
結果を反映するシートのシート名：整形後予定表

マクロ実行時、”予定表”が存在することが条件です。
”整形後予定表”は、なければ、新規作成されます。あれば、上書きされます。

上記のような条件で問題なければ、マクロ提供は可能です。
その場合は、予定を入力するシートのシート名と結果を反映するシートのシート名もご提示ください。

この回答へのお礼

tatsu99さま
ご回答ありがとうございます。

シート名は特に何も決めていませんので
予定を入力するシート名は「予定表」
結果を反映するシート名は「整形後予定表」で結構です。
またよろしくお願いいたします。

お礼日時：2017/03/11 23:50

No.9 回答者： yokomaya 回答日時： 2017/03/11 19:40

何度もすみません。

こっちでよろ。

Const LastTime As Date = "21:00"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Target.Offset(0, 2).MergeCells Then
Application.EnableEvents = False
Application.SendKeys Cells(Target.Row, 1).Text + Chr(13)
Application.EnableEvents = True
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column Mod 4 = 3 Then
If Target < Target.Offset(0, -1) + TimeSerial(0, 10, 0) Or _
Target > LastTime Then '外れてたら進まない
Application.EnableEvents = False
Beep
Target.Offset(0, 0).Select
Application.EnableEvents = True
Else

If Target.Offset(0, 1).MergeCells Then
With Target.Offset(0, 1).MergeArea
.UnMerge '結合解除
.Borders(xlInsideHorizontal).Weight = xlThin '罫線再描画
End With
End If
Target.Offset(0, 1).Resize((Target - Target.Offset(0, -1)) / TimeSerial(0, 5, 0), 1).Merge
Target.Offset(0, 1).Select '入れる位置が不適切だった
End If
End If

End Sub

この回答へのお礼

yokomayaさま
ご回答ありがとうございます。

Worksheetのイベントプロシージャーやってみました。
エクセルにこのような機能があることを初めて知りとても驚きました。
無事開始時間入力→終了時間入力でセル結合されました。

大変わかりやすいアドバイスを頂きありがとうございます。
まだ結合後に罫線で外枠を囲んだり、
開始時間：終了時間：内容をコピペした後の処理等で、
少し苦戦していますが、こちらのコードを参考に
またさらに挑戦してみたいと思います。
素晴らしい機能をご教授頂きありがとうございました。

お礼日時：2017/03/12 03:35

No.8 回答者： yokomaya 回答日時： 2017/03/11 19:26

No2だった。

すみません。
あとEnterキーを押した後セル移動は横で
お願いします。
（オプション→詳細設定）

No.7 回答者： yokomaya 回答日時： 2017/03/11 19:19

No1です。

コードにしてみました。
開始時間はダブルクリックでどうかなと。
表の下限が判らなかったので18：00で
終了時間上限チェックしてます。
もっとチェック必要ですが
手抜きです。

Const LastTime As Date = "18:00"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Target.Offset(0, 2).MergeCells Then
Application.EnableEvents = False
Application.SendKeys Cells(Target.Row, 1).Text + Chr(13)
Application.EnableEvents = True
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column Mod 4 = 3 Then
If Target < Target.Offset(0, -1) + TimeSerial(0, 10, 0) Or _
Target > LastTime Then　’外れてたら進まない
Application.EnableEvents = False
Beep
Target.Offset(0, -1).Select
Application.EnableEvents = True
Else

If Target.Offset(0, 1).MergeCells Then
With Target.Offset(0, 1).MergeArea
.UnMerge　　’結合解除
.Borders(xlInsideHorizontal).Weight = xlThin　’罫線再描画
End With
End If
Target.Offset(0, 1).Resize((Target - Target.Offset(0, -1)) / TimeSerial(0, 5, 0), 1).Merge
End If
End If
Target.Offset(0, 1).Select　’これ本来要らないけど変な選択状態が残るので入れました
End Sub

No.6 回答者： WindFaller 回答日時： 2017/03/11 17:07

こんにちは。

>現在は1枚のシートで作業しておりますが、
私は、一枚のシートで、現段階では、1日づつ行うスタイルです。

しかし、これを作る時に、一番気をつけなくてはならないのは、浮動小数点演算誤差でしょう。今回のA列で時間値をドラッグコピーするさいも、誤差が出てしまっていますから、見えない部分を気をつけないと、正しくでない可能性もあります。

以前この誤差を使って、私の書いたマクロでは正しくできないと批判した方がいましたが、マクロを扱う人には常識なので、予め、ここに書いておきます。
----------------------
ドラック・コピーを使う時は、以下のようにします。
A列は、
A3: 8:00
A4:=TEXT(A3,"H:MM")+"0:05"
という数式です。
だから、マクロ全体も、Double型の数値は使わないようになっています。
----------------------
それと、これは、システムになりますから、ここの掲示板でVBAのコードで供給できるのは一部でしかないということは最初におことわりしておきます。

ただ、私の書いたものは、あくまでも、自分の頭の体操のつもりで作っているので、気に入らないければ、ノーコメントでも構いません。

これは、カーソルをB～D においた場合は、その列の処理をするし、F～Hでは、その列を処理します。超過している時には、「超過」と出てきます。

一度処理したところを、もう一度実行すれば、やり直します。

'//

Sub ScheduleOptimizing()
　Dim LastRow As Long
　Dim stRng As Range
　Dim nxRng As Range
　Dim LRng As Range
　Dim diff As Integer
　Dim cl As Integer, i As Long, j As Long
　Dim rDiff As Long, Remain As Long
　cl = ActiveCell.Column
　
　j = Int(cl / 5) * 4 + 2
　
　LastRow = Cells(Rows.Count, 2).End(xlUp).Row
　i = 1
　
　Set stRng = Cells(2, j)
　
　Set LRng = stRng.End(xlDown)
　If LRng.Row > 10 ^ 4 Then Exit Sub　　'データがない場合
　If LRng.Offset(, 2).MergeCells Then
　　If MsgBox("この列は、すでに実施済みですから、やり直しますか？", vbOKCancel) = vbCancel Then
　　Dim FA As String
　　Dim c As Range
　　　Exit Sub
　　Else
　　　Cells(2, j + 2).Resize(LastRow, 1).MergeCells = False
　　　Cells(2, j + 2).Resize(LastRow, 1).ClearFormats
　　　Set c = Cells(2, j + 2).Resize(LastRow, 1).Find("超過*", , xlValues, 2)
　　　　If Not c Is Nothing Then
　　　　 FA = c.Address
　　　　　　　Do
　　　　　　　c.Value = Mid(c.Value, 1, InStr(c.Value, "超過") - 1)
　　　　　　　Set c = Cells(2, j + 2).Resize(LastRow, 1).FindNext(c)
　　　　　　　If c Is Nothing Then Exit Do
　　　　　　Loop Until c Is Nothing
　　　　　End If
　　　 End If
　End If
　'---Start ---
　Do
　　diff = Fix(LRng.Offset(, 1).Value * 24 * 60) - Fix(LRng.Value * 24 * 60)
　　rDiff = Int(diff / 5)
　　With LRng
　　　If Application.CountA(.Resize(rDiff)) > 1 Then
　　　　Remain = LRng.Offset(, 1).End(xlDown).Cells.Value * 24 * 60 - .Cells(1, 2).Value * 24 * 60
　　　　Remain = Int(Remain / 5)
　　　
　　　　rDiff = rDiff - Remain 'コンフリクトを調べる
　　　　
　　　　.Offset(, 2).Value = .Offset(, 2).Value & " 超過" & Remain * 5 & "分"
　　　End If
　　End With
　　If rDiff > 1 And rDiff < 30 Then 'コマ数 30以下
　　　With LRng.Offset(, 2).Resize(rDiff)
　　　　.Merge
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　.Interior.ColorIndex = 40
　　　　.Borders.LineStyle = 1
　　　　.Borders.Weight = xlMedium
　　　End With
　　　Else
　　End If
　　Set stRng = LRng
　　i = LRng.Row
　　If i >= LastRow Then Exit Do
　　Set LRng = stRng.End(xlDown)
　Loop

End Sub

この回答へのお礼

WindFallerさま
ご回答ありがとうございます。

A列のドラッグコピーに関して、そのような差が生じてしまうとは知りませんでした。大変わかりやすいアドバイスを頂きありがとうございます。
まだまだ苦戦していますが、こちらのコードも参考に挑戦してみたいと思います。
ありがとうございました。

お礼日時：2017/03/12 02:13

No.5 回答者： yokomaya 回答日時： 2017/03/11 17:06

＞予定を入力するシートと結果を反映するシートが別の方が良いようですが、それも可能でしょうか？

可能ですよ。
というかｅｘｃｅｌに通じた人は基本的に表を２次元で
考える習性があります。その方が設計が楽なので。
例えばこの表横の列を見ると日付要素と、項目要素の2重構造になっているわけです。
最終的な出力はこうだとしても、データで考えるときは
日付の列は一つだけにして縦に並べた方が、圧倒的に
処理はしやすいんです。横の要素を複雑に考えないでいいから。
縦方向の結合はプログラムでやるとしたら全く行は隙間を開けずに
縦に連続してスケージュール登録するイメージです。

でも操作的にはどうでしょう？
この表の埋まり具合と見比べながら入力するから
重ならないようにも目で確認できるんですよね。
僕の見解は、このケースでは分けると操作性が犠牲に
なりそうな気がします。

No.4 回答者： ママチャリ 回答日時： 2017/03/11 15:08

図１を作成した後で、下記のマクロを実行するとお望みの結果が得られるはずです。

ただ、予定を決める時って、線を引く（今回の場合はセル結合）のが先で、時刻（数字）を入力するのは、その後のような気がするのですが、そうやってスケジュールを作るのは、私だけですかね？

Sub sample()
Dim c As Long
Dim r As Long
Dim s As Long
For c = 4 To 28 Step 4
For r = 161 To 3 Step -1
Cells(r, c).MergeCells = False
If Cells(r, c - 2).Value <> "" Then
s = myMinute(Cells(r, c - 2).Value, Cells(r, c - 1).Value)
If s > 0 Then Cells(r, c).Resize(s).MergeCells = True
End If
Next r
Next c
End Sub

Private Function myMinute(f As Variant, t As Variant) As Long
On Error Resume Next
myMinute = WorksheetFunction.RoundUp(((Hour(t) * 60 + Minute(t)) _
- (Hour(f) * 60 + Minute(f))) / 5, 0)
End Function

この回答へのお礼

ママチャリさま
ご回答ありがとうございました。

今手元にパソコンがないため確認できませんが、早速試してみます。

おっしゃる通り、スケジュールを管理するにはこの表では不向きかと思います。
実際にはスケジュールの一覧が別にあり、それを参照してこのような視覚的にわかりやすい1週間分のスケジュールを作成していました。

データの入力は問題無いのですが、セルの結合は数えながらで大変な作業でしたので、
これでできれば大助かりです。
ありがとうございました。

お礼日時：2017/03/11 16:38

No.3 回答者： tatsu99 回答日時： 2017/03/11 12:34

１）次の週のスケジュールを作るときは、このシートを再利用するのでしょうか。

そうすると、セル結合した部分を元に戻す必要がありますが、それを考慮されてますでしょうか。
２）図２の9行を例にとると、
A列　8:30　B列　8:30　C列　9:10　となってます。
B列の時刻は、必ず、同一行のA列の時刻に一致すると理解して良いですか。
３）C列の終了時刻が、次のイベントの開始時刻に重なることはないですか。

この回答へのお礼

tatsu99ラックさま
ご回答ありがとうございます。

1) 現在は1つのシートをそのまま再利用しております。
おっしゃる通り毎回結合を解除していますが、予定を入力するシートと結果を反映するシートが別だと一番理想ですがそれも可能でしょうか？

2) おっしゃる通りです。B列の時刻は必ずA列の時刻に一致しています。

3) その通りです。C列の時刻が次のイベントに重なることはありません。

大変恐れ入りますがよろしくお願いいたします。

お礼日時：2017/03/11 15:19

No.2 回答者： yokomaya 回答日時： 2017/03/11 11:56

勿論可能です。

しかしながら、それだけでは不便です。
一般的にスケジュールというものは変更もありえるのが
普通ですよね。同時に入力間違いも考えられる。
それらを総合的に考えるとセルの結合は終了列の時間を入力したときに
（まずすでに結合されていたらそれを一旦範囲確認して解除する。修正に対応）
下方向のスケジュールを確認して入力した時間まで結合が可能なら
結合するという流れになるんじゃないでしょうか。

実際のコードは時間がかかるのでヒントだけ

主としてシートのイベントを使うのでシート名右クリック→
コードの表示で出てくるシートのコードペインに記述します。

Private Sub Worksheet_Change(ByVal Target As Range)
で
Range.column を４でわった余りが３なら
（終了時間の列なら）
まずTarget.Offset(0, 1).MergeCellsを確認
trueなら既に結合されているから
その範囲である
Target.Offset(0, 1).MergeAreaを確認
範囲の先頭セルならその範囲の結合解除。
でなかったら、上の方のスケジュールで既に
結合されてるから、その時間の行には入力しちゃ
ダメってことだけど（この判定をするよりも
後の結合のついでに時間列に入力制限かけるほうが妥当かも）

で結合はTarget.Offset(0, 1).Resize(x,1).merge
のxを先に計算すればいい。
といっても、終了-開始を5分で割るだけだから難しくないよね。
１０分未満なら結合に行かないのも必要かな？
多少漏れてるかもだけど、こんなイメージです。

この回答へのお礼

yokomayaさま
ご回答ありがとうございます。

大変わかりやすいヒントを頂きありがとうございます。大まかな流れが掴めましたが、まだまだ苦戦しそうです。

こちらのコードも参考に挑戦してみたいと思います。
ありがとうございました。

お礼日時：2017/03/11 15:41