VBA 表からカレンダー形式に変換

前回はJavascript/C#版で今回はVBA版

○○表という感じの帳票を作る場合、行が単位で列が明細というのが一般的。

明細の中に納期や出荷日など日付に関わる情報が入っていることも多く、そこで問題になるのが、この日付情報同士の関係性がパッと把握できないこと。

日付情報がおまけの場合はいいけど、日付情報が重要な場合は把握しやすいフォーマットに変換してみようということで、表からカレンダーに変換する機能を作成してみた。

ループが２重になるので、行数が多い場合は工夫したほうがいいかもしれない。行数が少なければ問題ないと思う。

Sub CreateCalendar()

y = 2020
m = 1

For Each w In Sheets
  If w.Name = "カレンダ" Then
    w.Delete
    Exit For
  End If
Next

Set w = Sheets.Add
w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"
w.Cells(2, 2).Value = "月"
w.Cells(2, 3).Value = "火"
w.Cells(2, 4).Value = "水"
w.Cells(2, 5).Value = "木"
w.Cells(2, 6).Value = "金"
w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))
endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

  For c = 1 To 7
  
    If (r = 3 And c < startWeekDay) Or (counter > endDay) Then
    
    Else
    
      w.Cells(r, c).Value = counter
      w.Cells(r + 1, c).Value = GetValue(y, m, counter)
      
      counter = counter + 1
    
    End If
    
  Next

Next

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")
  w.Rows(r).RowHeight = 17
Next

For Each r In Split("4,6,8,10,12,14", ",")
  w.Rows(r).RowHeight = 69
Next

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")
  w.Rows(r).HorizontalAlignment = xlLeft
Next

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")
  w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous
Next

For Each c In Split("1,2,3,4,5,6,7,8", ",")
  w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"
matchColumn = 3
valueColumn = 2
startRow = 2
endRow = 11

For r = startRow To endRow

  If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then
    GetValue = Sheets(sheetName).Cells(r, valueColumn).Value
    Exit Function
  End If

Next

End Function

100

101

102

103

104

105

Sub CreateCalendar()

y = 2020

m = 1

For Each w In Sheets

If w.Name = "カレンダ" Then

w.Delete

Exit For

End If

Set w = Sheets.Add

w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"

w.Cells(2, 2).Value = "月"

w.Cells(2, 3).Value = "火"

w.Cells(2, 4).Value = "水"

w.Cells(2, 5).Value = "木"

w.Cells(2, 6).Value = "金"

w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))

endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

For c = 1 To 7

If (r = 3 And c < startWeekDay) Or (counter > endDay) Then

Else

w.Cells(r, c).Value = counter

w.Cells(r + 1, c).Value = GetValue(y, m, counter)

counter = counter + 1

End If

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")

w.Rows(r).RowHeight = 17

For Each r In Split("4,6,8,10,12,14", ",")

w.Rows(r).RowHeight = 69

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")

w.Rows(r).HorizontalAlignment = xlLeft

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")

w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous

For Each c In Split("1,2,3,4,5,6,7,8", ",")

w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"

matchColumn = 3

valueColumn = 2

startRow = 2

endRow = 11

For r = startRow To endRow

If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then

GetValue = Sheets(sheetName).Cells(r, valueColumn).Value

Exit Function

End If

End Function