エクセル マクロ 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.15 ベストアンサー 回答者： tatsu99 回答日時： 2017/03/12 22:02

No13です。

＞MsgBox ("3")まで表示されまして
＞「×　Rangeクラスのselectメソッドが失敗しました」
貴重な情報、ありがとうございました。
Rangeの指定方法を変えました。
前回のは、全て削除し、以下のマクロで入れ替えてください。
文字数オーバーで格納できませんでしたので、下記URLに登録しました。
http://climbi.com/b/9646/0
ここから、コピペしてください。

この回答へのお礼

tatsu99さま
ご回答ありがとうございます。
大変手間の掛かる作業をしていただきありがとうございました。
ご指定のURLから新しいコードをコピペさせていただきましたが
症状がまた同じようでした。
エクセルのバージョンも関係していますでしょうか？

状況の画面を補足にて画像添付いたします。
力量が無く、度々申し訳ありませんがよろしくお願いいたします。

お礼日時：2017/03/12 22:32

No.21 回答者： tatsu99 回答日時： 2017/03/13 08:10

No19です。

もしかして、私の提示したマクロをシートモジュールに書いていませんか。
シートモジュールではなく、標準モジュール(module1)に書いてください。（添付図の黄色部分）
シートモジュールに書いた私のマクロは、削除してから、標準モジュールに書いてください。

この回答へのお礼

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

おっしゃる通りでした(T_T)
標準モジュールにしたところ正常に動作完了いたしました！！

このような初歩的な間違いをしてしまい
tatsu99さまの貴重なお時間を割いて頂いてしまい
大変申し訳ありませんでしたm(_ _)m

求めていた物以上のスケジュール表が完成し感謝感激です！！

手間の掛かる作業を、最後まで丁寧に何度も繰り返していただき
本当にありがとうございました。

完成まで見捨てずにご教授いただきまして
本当にありがとうございました。

tatsu99さま、また皆さまの回答を参考に今後も基本から勉強させて頂きます。

また機会がありましたら、その節はどうぞよろしくお願い致します。

本当にありがとうございましたm(_ _)m

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

No.20 回答者： tatsu99 回答日時： 2017/03/13 03:12

No19です。

こちらでもexcel2013で確認しました。正常に終了しましたので、バージョンの問題ではないかもしれません。
とりあえず、報告まで。

No.19 回答者： tatsu99 回答日時： 2017/03/13 01:06

>こちらのエクセルのバージョンですが、

>excel２０１３とexcel２０１６があり、
>どちらも同じ症状でした。
>今は個人のPCで確認していましたので、
>明日職場のPCにて早速確認してみます！

こちらでも、評価版をダウンロードしてexcel2013で試してみます。
ダウンロード及び確認で時間がかかると思いますので、
職場でうまくいかなかった場合は、このスレッドを閉じないで、しばらくの間、このままにしておいていただけますでしょうか。

No.18 回答者： tatsu99 回答日時： 2017/03/12 23:29

No16です。

すみません。念のため、もう一か所、追加します。④を追加してください。
Public Sub スケジュール整形()
Const sheetName As String = "整形済予定表" '出力用シート名
Dim sh1, sh2, ws As Worksheet
Set sh1 = Worksheets("予定表")
'スケジュールのチェックを行う。エラーがあれば終了する。
sh1.Activate　・・・④
If CheckSchedule(sh1, False) = False Then Exit Sub
'出力用シートがあれば、削除する

この回答へのお礼

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

大変申し訳ありません。やはり同じ結果となってしまいました(:_;)
職場のPCで動作すれば問題ないので出来ることを祈っています！！
ありがとうございました。

お礼日時：2017/03/12 23:54

No.17 回答者： tatsu99 回答日時： 2017/03/12 23:09

No16です。

追加の番号を間違えました。
sh2.Activate ・・・・①
sh.Activate　・・・②
sh.Activate　・・・②　←　③が正しいです。訂正します。

No.16 回答者： tatsu99 回答日時： 2017/03/12 23:05

No15です。

＞エクセルのバージョンも関係していますでしょうか？
もしかしたら、そうかもしれません。当方は、excel2007です。参考までに、あなたのexcelのバージョンを提示していただけますか。

実行時エラー　１００４に関しては、Range.selectメソッドで失敗する要因として、
シートがactivateになっていないことが原因の場合があるようです。
CheckScheduleの先頭でactivateしているのが、いつのまにか、効かなくなってるのかもしれません。

念のため、以下の行を追加して、確認していただけませんでしょうか。

Public Sub スケジュール整形()の最後のほうです。①を追加します。
'出力用シートを整形する
sh2.Activate ・・・・①
If CheckSchedule(sh2, True) = False Then Exit Sub
MsgBox ("完了")

Private Function CheckSchedule(ByVal sh As Worksheet, ByVal execute As Boolean) As Boolean中ほどです。
②③を追加します。
'エラーがあれば、該当項目を選択し、エラー表示後、終了する
If errcd <> 0 Then
rgstr = ConvertToLetter(col) & row & ":" & ConvertToLetter(col + 2) & row
sh.Activate　・・・②
Range(rgstr).Select
MsgBox (Cells(1, col + 2).Text & "の" & Cells(row, 1).Text & "の" & errname(errcd) & "が不正です" & vbLf & "処理を打ち切ります")
Exit Function
End If
'実行モードONかつ２行以上のイベントならセルを結合する
If execute = True And row < erow Then
rgstr = ConvertToLetter(col + 2) & row & ":" & ConvertToLetter(col + 2) & erow
sh.Activate　・・・②
Range(rgstr).Select
Selection.MergeCells = True
Selection.Borders(xlEdgeLeft).Weight = xlMedium
Selection.Borders(xlEdgeTop).Weight = xlMedium
Selection.Borders(xlEdgeBottom).Weight = xlMedium
Selection.Borders(xlEdgeRight).Weight = xlMedium
End If

以上、①②③を追加してください。

この回答へのお礼

tatsu99さま
ご回答ありがとうございました。
大変申し訳ありませんが今回も同じ症状になってしまいました。

こちらのエクセルのバージョンですが、
excel２０１３とexcel２０１６があり、
どちらも同じ症状でした。

今は個人のPCで確認していましたので、
明日職場のPCにて早速確認してみます！

手間の掛かる作業を、何度も丁寧にご教授していただき
本当にありがとうございました。

お礼日時：2017/03/12 23:40

No.14 回答者： yokomaya 回答日時： 2017/03/12 19:28

＞何度試しても「整形後予定表」シートに「予定表」内容がコピーされたタイミングで

＞「×　400」の表示が出てマクロが止まってしまいます。
＞「予定表」シートのデータを変えたり色々試してみましたが症状は変わりません。
＞「予定表」シート内のデータ内容に問題があるのでしょうか？

横槍ですが、内容には踏み込みませんので。

ブレークポイントとステップ実行はこういったデバッグでとても
大事なので覚えてください。でないとイベント関連は絶対にデバッグ
できません。

で、問題は「コピーされたタイミングで」が極めてアバウトで
多分エラー行で停止してくれなかったと想像しますが
その場合でも少し手前の行にブレークポイントを設定して実行すると
任意の行で一旦停止します。
そこからステップ実行すればエラーの発生する行を特定できます。
エラーの場所が判るか、判らないかが、大違いなのは
想像に難くないでしょう？

ブレークポイントやステップ実行はVBAとあわせてググれば
使用例があるので、ぜひ身に着けてくださいね。

この回答へのお礼

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

今回自分の力量不足でエラー箇所がわかりませんでした。(^^;
ブレークポイント機能が今まで使ったことがないので
またアドバイスを参考に、今後挑戦してみたいと思います。
また何かありましたら、その節はご教授よろしくお願い致します。
ありがとうございました。

お礼日時：2017/03/12 20:40

No.13 回答者： tatsu99 回答日時： 2017/03/12 19:07

No12です。

X　４００の表示の前に添付の画像のようなエラーは出力されていませんでしょうか。
（添付の例は故意に説明用に出力したもので、エラーの内容は本件とは関係ありません）
もし、出ていれば、そこで、デバッグを選択すると、マクロのソースのエラー箇所が表示されますので、
そこ箇所を教えていただけますでしょうか。

もし、添付の画像のようなエラーが出ていなければ、エラーの箇所を絞り込む必要があります。
このエラーは、こちらでは、再現できない為、対策が取れませんが、どこで、エラーが発生しているか、絞り込みを
したいと考えています。

Public Sub スケジュール整形()　内の以下の箇所のどこかなので、

'予定表を出力用シートにコピー
sh1.Copy after:=Worksheets(Worksheets.Count)
MsgBox ("1")
Worksheets(Worksheets.Count).Name = sheetName
MsgBox ("2")
Set sh2 = Worksheets(sheetName)
'出力用シートを整形する
MsgBox ("3")
If CheckSchedule(sh2, True) = False Then Exit Sub
MsgBox ("完了")

のように、msgbox("1")等を追加し、どこまで進むかを確認していただけませんでしょうか。

この回答へのお礼

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

エクセルのシートで実行しますと
エラー表示は出ずに
MsgBox ("3")まで表示され
先ほどの「ｘ　400」になりました。

マクロソースの画面で実行しますと
エラー表示は出ずに
MsgBox ("3")まで表示されまして
「×　Rangeクラスのselectメソッドが失敗しました」
と表示されました。

力量がなく何度も大変申し訳ありませんがよろしくお願いいたします。

お礼日時：2017/03/12 20:21

No.12 回答者： tatsu99 回答日時： 2017/03/12 09:38

No10です。

予定を入力するシート名は「予定表」
結果を反映するシート名は「整形後予定表」で策しています。
以下のマクロを標準モジュールに登録してください。
マクロ実行時、予定表がないとエラーになります。
------------------------------------------------------
Option Explicit
Public Sub スケジュール整形()
Const sheetName As String = "整形済予定表" '出力用シート名
Dim sh1, sh2, ws As Worksheet
Set sh1 = Worksheets("予定表")
'スケジュールのチェックを行う。エラーがあれば終了する。
If CheckSchedule(sh1, False) = False Then Exit Sub
'出力用シートがあれば、削除する
For Each ws In Worksheets
If ws.Name = sheetName Then
Application.DisplayAlerts = False 'シート削除時の警告を出さないようにする
ws.Delete '既に該当シートがあるなら削除する
Application.DisplayAlerts = True 'シート削除時の警告を出すようにする（元に戻す）
Exit For
End If
Next ws
'予定表を出力用シートにコピー
sh1.Copy after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = sheetName
Set sh2 = Worksheets(sheetName)
'出力用シートを整形する
If CheckSchedule(sh2, True) = False Then Exit Sub
MsgBox ("完了")
End Sub
'スケジュールチェック及び整形
Private Function CheckSchedule(ByVal sh As Worksheet, ByVal execute As Boolean) As Boolean
Dim col, row As Long '列、行番号
Dim prev_erow As Long '前回イベントの終了時刻に対応する行番号
Dim erow As Long '終了時刻に対応する行番号
Dim errcd As Long 'エラーコード
Dim errname As Variant 'エラー項目名
errname = Array("", "開始時刻", "終了時刻", "イベント")
sh.Activate
CheckSchedule = False
For col = 2 To 26 Step 4
prev_erow = 0
For row = 3 To 159
'開始時刻、終了時刻、イベントの何れかが設定されていればチェックを行う
If Cells(row, col).Value <> "" Or Cells(row, col + 1).Value <> "" Or Cells(row, col + 2).Value <> "" Then
'開始時刻と終了時刻をチェックする
errcd = CheckTimes(row, Cells(row, col).Value, Cells(row, col + 1).Value, erow)
'イベントが空白ならエラー
If Cells(row, col + 2).Value = "" Then errcd = 3
If errcd = 0 And prev_erow > 0 Then
'開始時刻が前回イベントの終了時刻と重なるならエラー
If row <= prev_erow Then errcd = 1
End If
'エラーがあれば、該当項目を選択し、エラー表示後、終了する
If errcd <> 0 Then
Range(Cells(row, col), Cells(row, col + 2)).Select
MsgBox (Cells(1, col + 2).Text & "の" & Cells(row, 1).Text & "の" & errname(errcd) & "が不正です" & vbLf & "処理を打ち切ります")
Exit Function
End If
'実行モードONかつ２行以上のイベントならセルを結合する
If execute = True And row < erow Then
Range(Cells(row, col + 2), Cells(erow, col + 2)).Select
Selection.MergeCells = True
Selection.Borders(xlEdgeLeft).Weight = xlMedium
Selection.Borders(xlEdgeTop).Weight = xlMedium
Selection.Borders(xlEdgeBottom).Weight = xlMedium
Selection.Borders(xlEdgeRight).Weight = xlMedium
End If
'終了時刻に対応する行番号を前回イベント用へ退避
prev_erow = erow
End If
Next
Next
Range("A1").Select
'正常終了
CheckSchedule = True
End Function
'開始時刻、終了時刻のチェック（正常なら終了時刻に対応する行番号(erow)を設定する）
Private Function CheckTimes(ByVal srow As Long, ByVal stime As Variant, ByVal etime As Variant, ByRef erow As Long) As Long
Dim btime As Variant
Dim hh, mm As Long
'開始時刻のチェック
CheckTimes = 1
If stime = "" Then Exit Function '空白ならエラー
btime = Cells(srow, 1).Value
If Hour(btime) <> Hour(stime) Then Exit Function 'A列の時刻に一致しないならエラー
If Minute(btime) <> Minute(stime) Then Exit Function 'A列の時刻に一致しないならエラー
'終了時刻チェック
CheckTimes = 2
If etime = "" Then Exit Function '空白ならエラー
hh = Hour(etime)
If hh < 8 Or hh > 21 Then Exit Function '8時未満、21時超過はエラー
mm = Minute(etime)
If mm Mod 5 <> 0 Then Exit Function '分が5分単位でないならエラー
erow = 2 + (hh - 8) * 12 + mm \ 5
If erow < srow Or erow > 159 Then Exit Function '終了時刻が開始時刻以前、又は、範囲外ならエラー
'正常終了
CheckTimes = 0
End Function

この回答へのお礼

tatsu99さま
ご回答ありがとうございます。
何度試しても「整形後予定表」シートに「予定表」内容がコピーされたタイミングで
「×　400」の表示が出てマクロが止まってしまいます。
「予定表」シートのデータを変えたり色々試してみましたが症状は変わりません。
「予定表」シート内のデータ内容に問題があるのでしょうか？

画面表示を補足にて添付いたします。
力量が無く、大変申し訳ありませんがよろしくお願いいたします。

お礼日時：2017/03/12 18:33