Excel 2007 マクロ 日付けを反映

質問

Excel 2007 マクロ 日付けを反映
Sheet1とSheet2の同じIDがあれば、Sheet1のC列の商談に入っている日付をSheet2の該当する週に矢印で表示して、矢印の中に商談という文字を入れたいです。

「Sheet1とSheet2の同じIDがあれば」の部分は自分で作成できます。
下記の部分はマクロで実現することは可能でしょうか。実現可能でしたら、お教えください。
「Sheet1のC列の商談に入っている日付をSheet2の該当する週に矢印で表示して、矢印の中に商談という文字を入れたい」

完成図を添付します。

回答No.1

Wendy02 · ベストアンサー

この質問は、明らかに人に作ってもらうため内容ですね。
あまり凝った内容だと、レスが付きにくいと思います。何週目と出す計算が面倒です。

Sheet2 の矢印を入れるセルの高さは大きめにしたほうがよいです。
セルの高さに影響されます。

'//
Sub Test1()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shp As Shape
Const myTxt As String = "商談"
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
With sh1
　Set rng = .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
　Application.ScreenUpdating = False
　For Each c In rng
　　 If c.Value <> "" And IsDate(c.Text) Then
　　　 j = Application.Match(c.Offset(, -1).Value, sh2.Columns(2), 0)
　　　 If Not (IsError(j)) Then
　　　　 i = Int((Day(c.Value) + Weekday(c.Value - Day(c.Value))) / 7 + 0.9)
　　　　 If ChkObject(sh2.Cells(j, i + 4), sh2) = False Then
　　　　　 PutArrow myTxt, sh2.Cells(j, i + 4), sh2
　　　　 End If
　　　 End If
　　 End If
　Next
Application.ScreenUpdating = True
End With
End Sub
'//
Function PutArrow(myTxt As String, rng As Range, sh As Worksheet)
'矢印を書き入れる
Dim l As Double, t As Double, w As Double, h As Double
With sh
　 l = rng.Left: t = rng.Top: w = rng.Width: h = rng.Height + 5　'h:高さ
　 With .Shapes.AddShape(msoShapeRightArrow, l, t, w, h)
　　　.TextFrame.Characters.Text = myTxt
　　　.TextFrame.VerticalAlignment = xlVAlignCenter
　　　.Line.ForeColor.SchemeColor = 40
　　　.DrawingObject.Font.Bold = True
　 End With
End With
End Function
'//
Function ChkObject(rng As Range, sh As Worksheet) As Boolean
'オブジェクトの重複を避けるための関数
　Dim shp As Shape
　Dim flg As Boolean
　For Each shp In sh.Shapes
　　If Not Intersect(rng, shp.DrawingObject.TopLeftCell) Is Nothing Then
　　　flg = True
　　　Exit For
　　End If
　Next
　ChkObject = flg
End Function
'//
Sub AutoChapeDel()
'オプション
'右矢印だけ削除
Dim shp As Shape
With ActiveSheet
　For Each shp In .Shapes
　　If shp.AutoShapeType = msoShapeRightArrow Then
　　　 shp.Delete
　　End If
　Next
End With
End Sub

お礼

ご回答ありがとうございます。詳細なマクロを記載して頂きまして非常に助かりました。今後はあまり凝らない内容で自分でマクロが作成できるようにしたいと思います。