ゴリラストロングの雑記帳

月収10万円の広告収入を目指す自称専業ライターのブログです。




【VBA】ガントチャートをブロック矢印で作成するマクロを作成してみました。




どうも、ゴリラストロングです。 

 

今回はVBAで、ガントチャートをブロック矢印で作成するマクロを作成してみました。

 

【VBA】ガントチャートを作成するマクロ

VBAガントチャートを作成するマクロ

 

適当なマクロブックを作成し、シート1に「入力」というシート名で上記の表を作成してください。

また、シート2に「ガントチャート」という名前でシートを追加してください。

そのうえでマクロを実行すると下図の通りガントチャートが作成されます。

 

マクロ実行後に作成されるガントチャート

マクロ実行後に作成されるガントチャート

 

 

ソースコード

Sub ガントチャート作成マクロ()

Dim nrk As Object
Set nrk = ThisWorkbook.Worksheets("入力")

Dim gcht As Object
Set gcht = ThisWorkbook.Worksheets("ガントチャート")

gcht.Range("A1") = "工程名"
gcht.Range("B1") = "担当者"
gcht.Range("C1") = "日程"
gcht.Range("C1:D1").Merge
gcht.Range("C1").HorizontalAlignment = xlCenter
gcht.Range("E1") = nrk.Range("A4")
gcht.Range("E1").NumberFormatLocal = "yyyy/m/d"

Dim nissuu As Long
nissuu = nrk.Range("C4")



For i = 0 To nissuu - 1

gcht.Cells(1, 6 + i) = gcht.Cells(1, 5 + i) + 1

Next



Dim lastrow As Long
lastrow = nrk.Cells(Rows.Count, 1).End(xlUp).Row

Dim kouteisuu As Long
kouteisuu = (lastrow - 6) * 4 + 1

k = 7



For j = 2 To kouteisuu Step 4

gcht.Cells(j, 1) = nrk.Range("A" & k)
gcht.Range(Cells(j, 1), Cells(j + 3, 1)).Merge
gcht.Cells(j, 1).HorizontalAlignment = xlCenter
gcht.Cells(j, 1).VerticalAlignment = xlCenter

gcht.Cells(j, 2) = nrk.Range("B" & k)
gcht.Range(Cells(j, 2), Cells(j + 3, 2)).Merge
gcht.Cells(j, 2).HorizontalAlignment = xlCenter
gcht.Cells(j, 2).VerticalAlignment = xlCenter

k = k + 1

Next



m = 7



For l = 2 To kouteisuu Step 4

gcht.Cells(l, 3) = "予定開始日"
gcht.Cells(l + 1, 3) = "予定終了日"
gcht.Cells(l + 2, 3) = "開始日"
gcht.Cells(l + 3, 3) = "終了日"

gcht.Cells(l, 4) = nrk.Cells(m, 3)
gcht.Cells(l + 1, 4) = nrk.Cells(m, 4)
gcht.Cells(l + 2, 4) = nrk.Cells(m, 5)
gcht.Cells(l + 3, 4) = nrk.Cells(m, 6)

m = m + 1

Next



Dim lastrow2 As Long
lastrow2 = gcht.Cells(Rows.Count, 1).End(xlUp).Row + 3

gcht.Range(Cells(2, 4), Cells(lastrow2, 4)).NumberFormatLocal = "yyyy/m/d"

Dim lastcolumn As Long
lastcolumn = gcht.Cells(1, Columns.Count).End(xlToLeft).Column


gcht.Range(Cells(2, 5), Cells(3, 5)).Merge
gcht.Range(Cells(2, 5), Cells(3, 5)).AutoFill Destination:=gcht.Range(Cells(2, 5), Cells(3, lastcolumn))



For n = 4 To lastrow2 Step 2

gcht.Range(Cells(2, 5), Cells(3, 100)).Copy Destination:=gcht.Range(Cells(n, 5), Cells(n, 100))

Next



gcht.Columns.AutoFit

gcht.Range(Cells(1, 1), Cells(lastrow2, lastcolumn)).Borders.LineStyle = True




p = 2
q = 3



For o = 2 To lastrow2 Step 2

Dim startday As String
startday = gcht.Cells(o, 4)

Dim endday As String
endday = gcht.Cells(o + 1, 4)

If startday = "未着手" Then
    With gcht.Range(Cells(p, 5), Cells(q, lastcolumn))
        gcht.Shapes.AddShape msoShapeRectangle, .Left, .Top, .Width, .Height
    End With
    GoTo L1
End If

Dim startcolumn As Long
startcolumn = gcht.Rows(1).Find(What:=DateValue(startday), LookIn:=xlValues).Column
Debug.Print startcolumn

Dim endcolumn As Long
endcolumn = gcht.Rows(1).Find(What:=DateValue(endday), LookIn:=xlValues).Column
Debug.Print endcolumn

With gcht.Range(Cells(p, startcolumn), Cells(q, endcolumn))
        gcht.Shapes.AddShape msoShapeRightArrow, .Left, .Top, .Width, .Height
End With

L1:

p = p + 2
q = q + 2

Next



s = 7


On Error Resume Next

For r = 1 To lastrow2 Step 2

Dim kouteiname As String
kouteiname = nrk.Range("A" & s)

With gcht
    
    .Shapes(r).Fill.ForeColor.RGB = RGB(0, 255, 0)
    .Shapes(r + 1).Fill.ForeColor.RGB = RGB(255, 0, 255)
    .Shapes(r).TextFrame.Characters.Text = kouteiname
    .Shapes(r).TextFrame.Characters.Font.Size = 10
    .Shapes(r).TextFrame.Characters.Font.Bold = True
    .Shapes(r).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    
End With

s = s + 1

Next


End Sub

 

 

※こちらガントチャート作成関係の別記事です。

 是非ご覧になってください。 

gorilla-strong.hatenablog.com

 

 

最後までご覧いただきありがとうございます。

以上、ゴリラストロングでした。