会議室使用表へ自動入力を考えています
マクロ、VBAなどで次の条件で作成できないでしょうか?
条件:
※会議室はシートごとに
※平日10:00~21:00
※10:30-11:30など時間をまたぐときは10時のセルにも11時のセルにも入力
※日をまたぐときは日をまたいで
※利用がない時間は「ー」で入力
元データ(CSV)
開始日|開始時刻|終了日|終了時刻|会議室
12/3|10:30|12/3|11:30|会議室A
12/4|19:00|12/5|11:00|会議室B
12/5|19:30|12/5|19:50|会議室B
会議室使用表
会議室Aシート
|10:00|11:00|・・・|19:00|20:00
12/3|00:30|00:30|・・・|-|-
12/4|-|-|・・・|-|-
12/5|-|-|・・・|-|-
会議室Bシート
|10:00|11:00|・・・|19:00|20:00
12/3|-|-|・・・|-|-
12/4|-|-|・・・|01:00|01:00
12/5|01:00|01:00|・・・|00:20|-
よろしくお願い致します
質問に書かれた仕様と少し変えてしまいましたが、下記のようにしてどうでしょうか。
csvFilePath の行に読み込む CSV ファイルのパスを書いて実行下さい。
不明な点があれば、コメント下さい。
Option Explicit Const csvFilePath = "D:\Data\Reserve.csv" '// 読み込む CSVファイル名 '----------------------------------------------------------------------------------- Sub 予約表作成() '----------------------------------------------------------------------------------- Dim fso Set fso = CreateObject("Scripting.FileSystemObject") Dim lines lines = Split(fso.OpenTextFile(csvFilePath).ReadAll(), vbNewLine) Dim line Dim inf For Each line In lines inf = Split(line, ",") If UBound(inf) = 4 And InStr(line, "開始日") = 0 Then setDateInfo inf Next End Sub '----------------------------------------------------------------------------------- Sub setDateInfo(inf) '----------------------------------------------------------------------------------- Dim stDate Dim edDate stDate = CDate(inf(0)) edDate = CDate(inf(2)) Dim stTime Dim edTime stTime = CDate(inf(1)) edTime = CDate(inf(3)) Dim roomName roomName = inf(4) If edDate - stDate > 30 Then MsgBox "予約期間が1ヶ月を超えています。" Exit Sub End If Dim dt As Long Dim d If stDate = edDate Then SetOneDay stDate, stTime, edTime, roomName Else SetOneDay stDate, stTime, TimeSerial(21, 0, 0), roomName For d = stDate + 1 To edDate - 1 SetOneDay d, TimeSerial(10, 0, 0), TimeSerial(21, 0, 0), roomName Next SetOneDay edDate, TimeSerial(10, 0, 0), edTime, roomName End If End Sub '----------------------------------------------------------------------------------- Sub SetOneDay(dt, st, et, rm) '----------------------------------------------------------------------------------- Dim wsName wsName = rm & Application.Text(dt, "(YYYYMM)") Dim dstWS As Worksheet On Error Resume Next Set dstWS = Worksheets(wsName) On Error GoTo 0 Dim r As Long Dim c As Long Dim ed As Long '// シート設定:なければ作成 If dstWS Is Nothing Then Worksheets.Add after:=Worksheets(Worksheets.Count) Set dstWS = Worksheets(Worksheets.Count) '// シートの設定 dstWS.Name = wsName dstWS.Columns("B:L").ColumnWidth = 6 ed = Day(DateSerial(Year(dt), Month(dt) + 1, 0)) For c = 2 To 12 dstWS.Cells(1, c).Value = TimeSerial(c + 8, 0, 0) Next For r = 1 To ed dstWS.Cells(r + 1, "A").Value = DateSerial(Year(dt), Month(dt), r) Select Case Weekday(dstWS.Cells(r + 1, "A").Value) Case vbSaturday: dstWS.Cells(r + 1, "A").Resize(1, 12).Interior.ColorIndex = 37 Case vbSunday: dstWS.Cells(r + 1, "A").Resize(1, 12).Interior.ColorIndex = 38 End Select Next dstWS.Range("A2").Resize(ed, 1).NumberFormat = "mm月dd日" dstWS.Range("B1").Resize(ed + 1, 11).NumberFormat = "h:mm" dstWS.Range("A1").Resize(ed + 1, 12).HorizontalAlignment = xlCenter dstWS.Range("A1").Resize(ed + 1, 12).Borders.Weight = xlThin End If '// 時間の記入 Dim t Dim h As Long With dstWS For h = Hour(st) To Hour(et) t = WorksheetFunction.Min(et, TimeSerial(h + 1, 0, 0)) - WorksheetFunction.Max(st, TimeSerial(h, 0, 0)) If t > 0 Then .Cells(Day(dt) + 1, h - 8).Value = .Cells(Day(dt) + 1, h - 8).Value + t Next End With End Sub
質問に書かれた仕様と少し変えてしまいましたが、下記のようにしてどうでしょうか。
csvFilePath の行に読み込む CSV ファイルのパスを書いて実行下さい。
不明な点があれば、コメント下さい。
Option Explicit Const csvFilePath = "D:\Data\Reserve.csv" '// 読み込む CSVファイル名 '----------------------------------------------------------------------------------- Sub 予約表作成() '----------------------------------------------------------------------------------- Dim fso Set fso = CreateObject("Scripting.FileSystemObject") Dim lines lines = Split(fso.OpenTextFile(csvFilePath).ReadAll(), vbNewLine) Dim line Dim inf For Each line In lines inf = Split(line, ",") If UBound(inf) = 4 And InStr(line, "開始日") = 0 Then setDateInfo inf Next End Sub '----------------------------------------------------------------------------------- Sub setDateInfo(inf) '----------------------------------------------------------------------------------- Dim stDate Dim edDate stDate = CDate(inf(0)) edDate = CDate(inf(2)) Dim stTime Dim edTime stTime = CDate(inf(1)) edTime = CDate(inf(3)) Dim roomName roomName = inf(4) If edDate - stDate > 30 Then MsgBox "予約期間が1ヶ月を超えています。" Exit Sub End If Dim dt As Long Dim d If stDate = edDate Then SetOneDay stDate, stTime, edTime, roomName Else SetOneDay stDate, stTime, TimeSerial(21, 0, 0), roomName For d = stDate + 1 To edDate - 1 SetOneDay d, TimeSerial(10, 0, 0), TimeSerial(21, 0, 0), roomName Next SetOneDay edDate, TimeSerial(10, 0, 0), edTime, roomName End If End Sub '----------------------------------------------------------------------------------- Sub SetOneDay(dt, st, et, rm) '----------------------------------------------------------------------------------- Dim wsName wsName = rm & Application.Text(dt, "(YYYYMM)") Dim dstWS As Worksheet On Error Resume Next Set dstWS = Worksheets(wsName) On Error GoTo 0 Dim r As Long Dim c As Long Dim ed As Long '// シート設定:なければ作成 If dstWS Is Nothing Then Worksheets.Add after:=Worksheets(Worksheets.Count) Set dstWS = Worksheets(Worksheets.Count) '// シートの設定 dstWS.Name = wsName dstWS.Columns("B:L").ColumnWidth = 6 ed = Day(DateSerial(Year(dt), Month(dt) + 1, 0)) For c = 2 To 12 dstWS.Cells(1, c).Value = TimeSerial(c + 8, 0, 0) Next For r = 1 To ed dstWS.Cells(r + 1, "A").Value = DateSerial(Year(dt), Month(dt), r) Select Case Weekday(dstWS.Cells(r + 1, "A").Value) Case vbSaturday: dstWS.Cells(r + 1, "A").Resize(1, 12).Interior.ColorIndex = 37 Case vbSunday: dstWS.Cells(r + 1, "A").Resize(1, 12).Interior.ColorIndex = 38 End Select Next dstWS.Range("A2").Resize(ed, 1).NumberFormat = "mm月dd日" dstWS.Range("B1").Resize(ed + 1, 11).NumberFormat = "h:mm" dstWS.Range("A1").Resize(ed + 1, 12).HorizontalAlignment = xlCenter dstWS.Range("A1").Resize(ed + 1, 12).Borders.Weight = xlThin End If '// 時間の記入 Dim t Dim h As Long With dstWS For h = Hour(st) To Hour(et) t = WorksheetFunction.Min(et, TimeSerial(h + 1, 0, 0)) - WorksheetFunction.Max(st, TimeSerial(h, 0, 0)) If t > 0 Then .Cells(Day(dt) + 1, h - 8).Value = .Cells(Day(dt) + 1, h - 8).Value + t Next End With End Sub
コメント(10件)
CSVを読み込んで、
実行時エラー'13'; 型が一致しません。となります。
デバッグ ステップインで、stDate = CDate(inf(0))までは進みます。
ご助言お願いします。
それが変換できなかったということだと思います。
CSV にはタイトル行がない前提にしていましたが、タイトルがあったりするでしょうか。
一度データだけのCSV で実行してみてもらえるでしょうか。
inf(0) の中身も記載いただくと、より正確な回答ができると思います。
方眼紙形式に出力されるんですね。
色の塗り分けはどのような法則になっているのでしょうか?
実は、最終的には稼働率もだしたいので、
希望としましては数値データで出力が希望ではあります。
色は単色でよければ、Array の中を1データにすればよいですが、時間集計をするのであれば、セルにデータを入れて条件付書式で色を着ける様な方法に変更したほうがよさそうです。
表示形式が現状でよければ修正コードをアップしますが、当初記載されたとおりの仕様をお望みでしょうか。
数値で出力にして頂けますと助かります。
また、Excelのバージョンは、2003、2007、2010になります。
よろしくお願い致します。
ご確認ください。
CSVデータにて2日以上またいでいるものに関して
正確に出力されませんでした。
12/3|10:30|12/6|11:30|会議室A
のような場合です。
修正対応しました。
何度も修正してくださりありがとうございました!