[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一覧表をカレンダー表示へ変換』（s55tac）
会議スケジュールの一覧を、カレンダー表示に自動変換をしたいのですが、
行き詰ってしまいまして、皆様の知恵をお貸し頂きたく存じます。
よろしくお願い申し上げます。
シート「日程」の A列：重要度が【A】かつ、C列：期間が【長】となっている
作業のみ、各会議の各日程が、シート「カレンダー」の該当する日にちのセルに対して
作業名 会議名
の表記で入力されるようにしたいです。
なお、同じ日に会議が重なった場合は、会議の列が左側の方をカレンダーで
上側に来るように表示させたいです。
よろしくお願いします。
シート：日程
重要度 作業名 期間 会議1 会議2 会議3 会議4
A 作業1 長 2017/5/1 2017/5/10 2017/5/19 2017/5/30 B 作業2 短 2017/5/3 2017/5/10 2017/5/16 2017/5/25 A 作業3 長 2017/5/5 2017/5/15 2017/5/30 2017/6/10 C 作業4 長 2017/5/10 2017/5/30 2017/6/7 2017/6/12 A 作業5 中 2017/5/2 2017/5/10 2017/5/16 2017/5/26 A 作業6 長 2017/5/3 2017/5/25 2017/6/14 2017/6/26
シート：カレンダー
月 火 水 木 金
2017/5/1 2017/5/2 2017/5/3 2017/5/4 2017/5/5
作業1 作業6 作業3
会議1 会議1 会議1
2017/5/8 2017/5/9 2017/5/10 2017/5/11 2017/5/12
作業1
会議2
2017/5/15 2017/5/16 2017/5/17 2017/5/18 2017/5/19
作業3 作業1
会議2 会議3
2017/5/22 2017/5/23 2017/5/24 2017/5/25 2017/5/26
作業6
会議2
2017/5/29 2017/5/30 2017/5/31 2017/6/1 2017/6/2
作業3
会議3
作業1
会議4
よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
カレンダーシートの日付は入力済として、同じ列に7日おきに日付が入っていて、
日程シート決定後に一括処理するなら、
Sub test()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim i As Long
Dim j As Long
Dim e As Long
Set mSh = Worksheets("日程")
Set tSh = Worksheets("カレンダー")
Application.ScreenUpdating = False
With mSh
e = .Range("A1").CurrentRegion.Rows.Count
For i = 4 To 7
For j = 2 To e
If .Cells(j, 1) = "A" And .Cells(j, 3) = "長" Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , , xlWhole)
If Not f Is Nothing Then
Set s = tSh.UsedRange.Find(.Cells(j, i) + 7, , , xlWhole)
If s Is Nothing Then
Set s = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
Else
Set s = s.End(xlUp).Offset(1)
End If
s.Value = .Cells(j, 2)
s.Offset(1).Value = .Cells(1, i)
End If
Set f = Nothing
Set s = Nothing
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
こんな感じで。
（ウッシ） 2017/02/28(火) 14:37
日付の行間数調節するように変更しました。
Sub test1()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim t As Range
Dim i As Long
Dim j As Long
Dim e As Long
Set mSh = Worksheets("日程")
Set tSh = Worksheets("カレンダー")
Application.ScreenUpdating = False
With mSh
e = .Range("A1").CurrentRegion.Rows.Count
For i = 4 To 7
For j = 2 To e
If .Cells(j, 1) = "A" And .Cells(j, 3) = "長" Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , , xlWhole)
If Not f Is Nothing Then
Set s = tSh.UsedRange.Find(.Cells(j, i) + 7, , , xlWhole)
If s Is Nothing Then
Set t = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
Else
If s.Offset(-1).Value <> "" Then
s.Resize(2).EntireRow.Insert
Set t = s.Offset(-2)
Else
Set t = s.End(xlUp).Offset(1)
If s.Row - t.Row = 1 Then
t.EntireRow.Insert
Set t = t.Offset(-1)
t.Select
Else
End If
End If
End If
t.Select
t.Value = .Cells(j, 2)
t.Offset(1).Value = .Cells(1, i)
End If
Set f = Nothing
Set s = Nothing
Set t = Nothing
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
（ウッシ） 2017/02/28(火) 15:11
ウッシ様
早速のコメントありがとうございます。
ただ、関数だけで何とかなるかと思っていたので、
最初に提示させていただいた内容はかなり簡略化したものでした。
自分で細かいところは置き換えて調整できるかと思っていたのですが、
マクロやVBAは不慣れなもので、うまく動きませんでした。
また、同じ日に会議が重なった場合は、会議の列が左ではなくて右側の方をカレンダーで
上側に来るように表示させたいです。
具体的なExcelファイルを以下にUPしましたので、二度手間になってしまい申し訳ないのですが、
もう少し詳しく教えていただけませんでしょうか。
よろしくお願いいたします。
（s55tac） 2017/02/28(火) 17:30
以下、改めて条件を記載します。
シート：日程のG列：種別が‘開発’かつJ列状況が‘作業中’となっている
プロジェクトのみ、K列：日程が‘見込’の行の各会議の各日程が、
シート「表示用カレンダー」の該当する日にちのセルに対して
テーマ名 会議名
で入力されるようにしたいです。
同じ日に会議が重なった場合は、会議の列が右側の方を
カレンダーの日にちのセルで上側に来るように表示させたいです。
文章で書くと解り辛いかもしれないので、画像に説明を追加しました。
http://yahoo.jp/box/Z-zjEX
よろしくお願いいたします。
（s55tac） 2017/02/28(火) 22:12
やけに複雑になってますね。
Sub test2()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim i As Long
Dim j As Long
Dim e As Long
Set mSh = Worksheets("日程")
Set tSh = Worksheets("表示用カレンダー")
' Set tSh = Worksheets("表示用カレンダー_縦")
Application.ScreenUpdating = False
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , , xlWhole)
If Not f Is Nothing Then
Set s = tSh.UsedRange.Find(.Cells(j, i) + 7, , , xlWhole)
If s Is Nothing Then
Set s = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
' Application.Goto s, True
' Stop
Else
Set s = s.End(xlUp).Offset(1)
' Application.Goto s, True
' Stop
End If
s.Value = .Cells(j - 2, 8) & vbLf & .Cells(2, i)
' Stop
End If
Set f = Nothing
Set s = Nothing
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
（ウッシ） 2017/02/28(火) 22:53
シート「カレンダー」の日付は入力されているものとします。
日付「2017/5/1〜2017/5/5」までの式です。
A3: =IFERROR(INDEX(日程!$B$2:$B$7,SMALL(IF((日程!$A$2:$A$7="A")*(日程!$C$2:$C$7="長")*(日程!$D$2:$G$7=A$2),ROW($A$1:$A$6),""),1)),"")
「Ctrl + Shift + Enter」キーで式を入力します。（配列数式）
A4: =IF(A3="","",INDEX(日程!$D$1:$G$1,MATCH(A$2,INDEX(日程!$D$2:$G$7,MATCH(A$3,日程!$B$2:$B$7,0),))))
２つの式をE列までコピーします。
A3の式をA5に、A4の式をA6にコピーしてA5の式を修正（1→2）して「Ctrl + Shift + Enter」キーで
式を入力します。
A5: =IFERROR(INDEX(日程!$B$2:$B$7,SMALL(IF((日程!$A$2:$A$7="A")*(日程!$C$2:$C$7="長")*(日程!$D$2:$G$7=A$2),ROW($A$1:$A$6),""),2)),"")
↑ここ
A5とA6の式をE列までコピーします。
作業と会議室の組み合わせが１日あたり３つ以上ある場合には、この操作を
繰り返します。
他の週についても同じように上の操作を繰り返します。
面倒かな？
（メジロ） 2017/03/01(水) 10:36
「作業と会議室の組み合わせが１日あたり３つ以上ある場合」
を考慮すると、「表示用カレンダー_縦」シートの方が処理しやすいので、
そちらにデータセットするようにします。
Sub test3()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim t As Range
Dim i As Long
Dim j As Long
Dim e As Long
Set mSh = Worksheets("日程")
Set tSh = Worksheets("表示用カレンダー_縦")
Application.ScreenUpdating = False
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , , xlWhole)
If Not f Is Nothing Then
Set s = tSh.UsedRange.Find(.Cells(j, i) + 7, , , xlWhole)
Application.Goto s, True
If s Is Nothing Then
Set t = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
Application.Goto t, True
Else
If s.Offset(-3).Value <> "" Then
s.Offset(-3).Resize(3).EntireRow.Copy
s.EntireRow.Insert
s.Offset(-3).Resize(3).EntireRow.ClearContents
With s.Offset(-3).EntireRow.Range("B1:H1").Borders(xlEdgeTop)
.LineStyle = xlDash
.Weight = xlHairline
End With
Set t = s.Offset(-3)
Else
Set t = s.End(xlUp).Offset(1)
Application.Goto t, True
If s.Row - t.Row = 1 Then
t.EntireRow.Insert
Set t = t.Offset(-1)
Application.Goto y, True
End If
End If
End If
Application.Goto t, True
t.Value = .Cells(j - 2, 8) & vbLf & .Cells(2, i)
End If
Set f = Nothing
Set s = Nothing
Set t = Nothing
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
（ウッシ） 2017/03/01(水) 11:36
メジロ様
ありがとうございます。
VBAとパラで共に検討させていただきます。
（s55tac） 2017/03/01(水) 22:16
色々とありがとうございます。
ご教示いただいた内容を基に、自分で少し手を加えたのですが、
もう少し教えていただけませんでしょうか。
カレンダーは「表示用カレンダー」を2年から3年に増やしました。
「日程」シートの日にちを修正することを想定し、「表示用カレンダー」シートを
開く毎に、カレンダーを一度クリアして書き込むようにしたつもりです。
ですが、各月の最終週にだけうまく書き込まれません。
どこがおかしいのか、お判りになりましたらお教えいただけませんでしょうか。
Private Sub Worksheet_Activate()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim i As Long
Dim j As Long
Dim e As Long
Set mSh = Worksheets("日程")
Set tSh = Worksheets("表示用カレンダー")
' Set tSh = Worksheets("表示用カレンダー_縦")
'===================カレンダーをクリア=====================
With tSh
For i = 5 To 53 Step 10
.Range("B" & i & ":CR" & i + 6).Value = ""
Next i
For i = 58 To 106 Step 10
.Range("B" & i & ":CR" & i + 6).Value = ""
Next i
For i = 111 To 159 Step 10
.Range("B" & i & ":CR" & i + 6).Value = ""
Next i
End With
'==========================================================
Application.ScreenUpdating = False
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , , xlWhole)
If Not f Is Nothing Then
Set s = tSh.UsedRange.Find(.Cells(j, i) + 7, , , xlWhole)
If s Is Nothing Then
Set s = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
' Application.Goto s, True
' Stop
Else
Set s = s.End(xlUp).Offset(1)
' Application.Goto s, True
' Stop
End If
s.Value = .Cells(j - 2, 8) & vbLf & .Cells(2, i)
' Stop
End If
Set f = Nothing
Set s = Nothing
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
よろしくお願いいたします。
（s55tac） 2017/03/01(水) 22:30
作業と会議室の組み合わせが１日あたり３件以上は無いという前提でいいですか？
（ウッシ） 2017/03/02(木) 07:52
作業と会議室の組み合わせが１日あたり３件以上は無いという前提で構いません。
よろしくお願いいたします。
（s55tac） 2017/03/02(木) 08:54
表示用カレンダーシートは作りがダメです。
一か月の表が５週しか無いですが、６週必要なのが普通では？
５週で運用するなら、例えば、2017/5のカレンダーの最後の土曜日は2017/6/3になるので、
次のカレンダーは、のスタートは日曜日2017/6/4でないと。
或いは、一つのカレンダーを月毎にするのなら６週表示にするかです。
決めの問題ですが、カレンダーの作成はどこかに開始年度を入力し３年度分は数式で
作るようにしてはどうですか？
あとは、表示用カレンダーは横長すぎて使い辛くないですか？
表示用カレンダー_縦の方がウィンドウ枠固定してスクロールすれば
見やすいと思うのですが、どうですか？
（ウッシ） 2017/03/02(木) 10:00
ご指摘ありがとうございます。
「表示用カレンダー_縦」の運用で進めることにします。
Sub test3()
にてご教示いただいたもので、カレンダーを３年分にして試してみました。
無事に作業と会議室の組み合わせが１日あたり３件以上あった場合でも動きました。
ただ、「日程」シートの日にちを修正することを想定し、
「表示用カレンダー_縦」シートを開く毎に、カレンダーを
一度クリアして書き込むようにしたいのですが、うまく動きません。
恐れ入りますが、追加でご教示いただけませんでしょうか。
よろしくお願いいたします。
（s55tac） 2017/03/02(木) 11:35
「表示用カレンダー」シートを開く毎に、「表示用カレンダー_縦」シートの
カレンダーを一度クリアして書き込むようにしました。
「表示用カレンダー」シートは、「表示用カレンダー_縦」シートからひと月分の
データを数式で参照して表示するようにすればいいと思います。
「表示用カレンダー」の初期年月日を、「日程」シートの日付の最小値にすれば
カレンダーの日付とデータが更新されるといいかと思います。
'「表示用カレンダー」シートのイベントモジュール
Private Sub Worksheet_Activate()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim i As Long
Dim j As Long
Dim e As Long
Dim r As Range
Dim d As Date
Set mSh = Worksheets("日程")
Set tSh = Worksheets("表示用カレンダー_縦")
d = #1/1/2999#
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
If d > .Cells(j, i) Then
d = .Cells(j, i)
End If
End If
Next
Next
End With
Me.Range("K1").Value = d
Application.ScreenUpdating = False
tSh.Unprotect
For Each r In tSh.UsedRange
If r.MergeCells = True Then
If r.Value <> "" Then
r.Value = ""
End If
End If
Next
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , xlValues, xlWhole)
If Not f Is Nothing Then
Set s = f.Resize(10).Find("", f, , xlWhole)
If s Is Nothing Then
Set s = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
Else
Set s = s.End(xlUp).Offset(1)
End If
s.Value = .Cells(j - 2, 8) & vbLf & .Cells(2, i)
End If
Set f = Nothing
Set s = Nothing
End If
Next
Next
End With
tSh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub
http://xfs.jp/jX1mBx
にファイル、アップしておきました。
（ウッシ） 2017/03/02(木) 12:04
ファイルダウンロードしました。
ありがとうございます。
「表示用カレンダー」だと1か月単位でしか表示されないので、
「表示用カレンダー_縦」シートを開く毎に、「表示用カレンダー_縦」シートの
カレンダーを一度クリアして書き込むように変えられませんでしょうか？
よろしくお願いいたします。
（s55tac） 2017/03/02(木) 14:21
表示用カレンダー_縦シートの日付は、表示用カレンダーシートの
セルK1の日付を参照しているので、表示用カレンダーシートはそのまま
にしておいて下さい。
Private Sub Worksheet_Activate()
Dim mSh As Worksheet
Dim tSh As Worksheet
Dim f As Range
Dim s As Range
Dim i As Long
Dim j As Long
Dim e As Long
Dim r As Range
Set mSh = Worksheets("日程")
Set tSh = Worksheets("表示用カレンダー_縦")
Application.ScreenUpdating = False
tSh.Unprotect
For Each r In tSh.UsedRange
If r.MergeCells = True Then
If r.Value <> "" Then
r.Value = ""
End If
End If
Next
With mSh
e = .Range("K" & Rows.Count).End(xlUp).Row
For i = 23 To 12 Step -1
For j = 5 To e Step 4
If .Cells(j - 2, 7).Value = "開発" And _
.Cells(j - 2, 10).Value = "作業中" And _
IsDate(.Cells(j, i)) = True Then
Set f = tSh.UsedRange.Find(.Cells(j, i), , xlValues, xlWhole)
If Not f Is Nothing Then
Set s = f.Resize(10).Find("", f, , xlWhole)
If s Is Nothing Then
Set s = tSh.Cells(Rows.Count, f.Column).End(xlUp).Offset(1)
Else
Set s = s.End(xlUp).Offset(1)
End If
s.Value = .Cells(j - 2, 8) & vbLf & .Cells(2, i)
End If
Set f = Nothing
Set s = Nothing
End If
Next
Next
End With
tSh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub
をセットすればいいです、
「表示用カレンダー」だと1か月単位でしか表示されない
というのも、必要な月数表示するように修正するのもいいかも。
（ウッシ） 2017/03/02(木) 14:30
ご対応ありがとうございました。
無事にうごいてくれました。
理想通りのものが出来て感激です！
ありがとうございました。
（s55tac） 2017/03/03(金) 09:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.