人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelで、元データ(CSV)から読み込んできて
会議室使用表へ自動入力を考えています
マクロ、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|?

よろしくお願い致します

●質問者: にゃんころね
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

質問者から

会議室Bシート、12/5の11:00のセル、間違いです。


1 ● Mook
●500ポイント ベストアンサー

質問に書かれた仕様と少し変えてしまいましたが、下記のようにしてどうでしょうか。

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
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ