『一覧表をカレンダー表示へ変換』（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しましたので、二度手間になってしまい申し訳ないのですが、
もう少し詳しく教えていただけませんでしょうか。

http://dtbn.jp/NhnHKd6

よろしくお願いいたします。
（s55tac） 2017/02/28(火) 17:30
----
具体的なExcelファイルをYahooボックスにUPし直しました。
http://yahoo.jp/box/VFyL0k

以下、改めて条件を記載します。
シート：日程の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