【Excel VBA】SQ日を求めるオリジナル関数を作る

先日来からの自作クラスのお話で恐縮だが、Yahoo!知恵袋にネタが転がっていたので、頭の体操がてらに作成してみた。

元ネタはこちら
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11189847436

なんでも株の取引の定められた日らしくて、3、6、9、12月の第2金曜日までの日数が必要らしい。

今回は普通に(?)セルに入力する関数として作成してみた。

 

コード

Public Function daysOf2ndFriday(d As Date) As Integer
    Dim cal As DateCalculatorClass
    Set cal = New DateCalculatorClass
    
    Dim data(3) As Date
    Dim i As Integer, m As Integer
    For i = 0 To 3
        m = i * 3 + 3
        data(i) = cal.GetDatesOfFixedDay(6, Year(d), m)(1)
        If d < data(i) Then
            daysOf2ndFriday = cal.DiffDays(d, data(i))
            Exit Function
        End If
    Next i
    
    Set cal = Nothing
End Function

実行結果

ちなみに私は株はしないので、この関数、せっかく作ったけれどまったく必要がない…。

【Excel VBA】DateCalculatorClass を使ってカレンダーを作ってみる

先日アップした DateCalculatorClass を使ってカレンダーを作ってみる。

エクセルの関数を使って万年カレンダー的なものを作るのは結構ややこしい。特に月末の日付表示の部分で頭が混乱してくる。

DateCalculatorClass を使えば簡単にカレンダー形式の二次元配列を得られるため、かなり簡単にカレンダーが作れる。

サンプルコード

Public Sub CreateCal()
    Dim cal As DateCalculatorClass
    Set cal = New DateCalculatorClass
    ' 年月の設定
    Dim y As Integer, m As Integer
    y = 2018
    m = 9
    ' カレンダーデータの取得
    Dim dt As Date
    Dim cData
    dt = DateSerial(y, m, 1)
    cData = cal.GetCalendar(dt)
    ' 曜日を書き込み
    Dim i As Integer, j As Integer
    For j = 0 To UBound(cData, 2)
        Cells(3, j + 1) = cData(0, j)
    Next j
    ' 3行おきに日付と祝日名を書き込み
    Dim r As Integer, c As Integer
    Dim hol As Variant
    For i = 1 To UBound(cData, 1)
        ' 3行おきの設定
        r = (i - 1) * 3 + 4
        For j = 0 To UBound(cData, 2)
            c = j + 1
            With Cells(r, c)
                ' 日付のみを表示する
                .NumberFormatLocal = "d"
                .Value = cData(i, j)
            End With
            ' 祝日の取得と書き込み
            hol = cal.IsHoliday(CDate(cData(i, j)))
            If hol <> False Then
                Cells(r + 1, c) = hol
            End If
        Next j
    Next i
    Set cal = Nothing
End Sub

実行結果

あとはセルの表示や罫線などを整えると良い。

こんな感じで。

振替休日の表示はちょっとくどいので、コード上で

If hol like “*振替休日” Then
hol = “振替休日”
End If

などと処理を入れたほうが良いかもしれない。

後の罫線の処理もマクロでやりたくなるところだけれど、万年カレンダーとして月ごとに書き換えていっても表示される枠は変わらないので、手作業でやってしまっていいと思う。

また、上記のコードをシートモジュールのワークシートチェンジイベントプロシージャで、月を入力したセルが変更されるタイミングで実行するようにしても良いかもしれない。

【Excel VBA】日付を扱いやすくするクラス

いつも即実用という感じのものばかり作っているので、たまにはコアな匂いのするものも書いてみようかと思いたってやってみました。

VBAで日付を扱うのはそんなに難しいことではないのだけれどなんか面倒くさいので、少しだけでもこのめんどくささが解消されればいいな、と思って書いてみました。

コードが長いのでたたんでおります。開いてコピってください(笑)

【2018年4月30日追記】

コード内でクラスをインスタンス化した時に今日の日付を保持するようにしていましたが、そうするとクラスをインスタンス化してずっとそのままにしておくと、今日が昨日や一昨日になってしまうこともあるため、コードを書き直しました。

DateCalculatorClass コード

'---------------------------------------------------------------------------------------
' Module    : DateCalculatorClass
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit
Private Const HOLIDAY_URL As String = "https://holidays-jp.github.io/api/v1/date.csv"
'---------------------------------------------------------------------------------------
' Procedure : Today
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get Today() As Date
    Today = Date
End Property
'---------------------------------------------------------------------------------------
' Procedure : Yesterday
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get Yesterday(Optional aDay As Date) As Date
    aDay = setDate(aDay)
    Yesterday = aDay - 1
End Property
'---------------------------------------------------------------------------------------
' Procedure : Tomorrow
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get Tomorrow(Optional aDay As Date) As Date
    aDay = setDate(aDay)
    Tomorrow = aDay + 1
End Property
'---------------------------------------------------------------------------------------
' Procedure : Weekday
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : String
'---------------------------------------------------------------------------------------
'
Public Property Get Weekday(Optional aDay As Date, Optional withBrackets As Boolean, _
                    Optional fullString As Boolean, Optional withEnglish As Boolean) As String
    aDay = setDate(aDay)
    Dim w As String
    If withEnglish Then
        If fullString Then
            w = WorksheetFunction.Text(aDay, "dddd")
        Else
            w = WorksheetFunction.Text(aDay, "ddd")
        End If
    Else
        If fullString Then
            w = WorksheetFunction.Text(aDay, "aaaa")
        Else
            w = WorksheetFunction.Text(aDay, "aaa")
        End If
    End If
    If withBrackets Then
        w = "(" & w & ")"
    End If
    Weekday = w
End Property
'---------------------------------------------------------------------------------------
' Procedure : DaysAfter
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DaysAfter(days As Integer, Optional startDate As Date) As Date
    startDate = setDate(startDate)
    DaysAfter = startDate + days
End Property
'---------------------------------------------------------------------------------------
' Procedure : DaysBefore
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DaysBefore(days As Integer, Optional startDate As Date) As Date
    startDate = setDate(startDate)
    DaysBefore = startDate - days
End Property
'---------------------------------------------------------------------------------------
' Procedure : DiffYears
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DiffYears(d1 As Date, Optional d2 As Date) As Integer
    d2 = setDate(d2)
    DiffYears = DateDiff("yyyy", d1, d2)
End Property
'---------------------------------------------------------------------------------------
' Procedure : DiffMonths
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DiffMonths(d1 As Date, Optional d2 As Date) As Integer
    d2 = setDate(d2)
    DiffMonths = DateDiff("m", d1, d2)
End Property
'---------------------------------------------------------------------------------------
' Procedure : DiffWeeks
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DiffWeeks(d1 As Date, Optional d2 As Date) As Integer
    d2 = setDate(d2)
    DiffWeeks = DateDiff("ww", d1, d2)
End Property
'---------------------------------------------------------------------------------------
' Procedure : DiffDays
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get DiffDays(d1 As Date, Optional d2 As Date) As Integer
    d2 = setDate(d2)
    DiffDays = DateDiff("d", d1, d2)
End Property
'---------------------------------------------------------------------------------------
' Procedure : EOMonth
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Public Property Get EOMonth(Optional aDay As Date, Optional months As Integer) As Date
    aDay = setDate(aDay)
    EOMonth = WorksheetFunction.EOMonth(aDay, months)
End Property
'---------------------------------------------------------------------------------------
' Procedure : HowOld
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Integer
'---------------------------------------------------------------------------------------
'
Public Function HowOld(birthday As Date, Optional aDate As Date) As Integer
    aDate = setDate(aDate)
    Dim y As Integer
    y = DiffYears(birthday, aDate)
    y = y + (Format(birthday, "mmdd") > Format(aDate, "mmdd"))
    HowOld = y
End Function
'---------------------------------------------------------------------------------------
' Procedure : IsHoliday
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : 引数で指定された日付が祝日であるかどうか判定する
' Return    : Variant:祝日であれば祝日名を返す。祝日でなければ False
'---------------------------------------------------------------------------------------
'
Public Function IsHoliday(d As Date) As Variant
    Dim hol As Variant
    hol = GetHolidayList()
    Dim i As Integer
    For i = 0 To UBound(hol)
        If d = CDate(hol(i, 0)) Then
            IsHoliday = hol(i, 1)
            Exit Function
        End If
    Next i
    IsHoliday = False
End Function
'---------------------------------------------------------------------------------------
' Procedure : getHolidayList
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : getCsvFromWeb 関数で取得した文字列データを二次元配列に整形して返す
' Return    : Variant:「祝日の日付 , 祝日名」の配列
'---------------------------------------------------------------------------------------
'
Public Function GetHolidayList() As Variant
    Dim line
    line = Split(getCsvFromWeb(HOLIDAY_URL), vbLf)
    If Not line(0) Like "2???-??-??,*" Then
        Call Err.Raise(555, , "祝日情報を取得できませんでした")
        Exit Function
    End If
    Dim data
    ReDim data(UBound(line) - 1, 1)
    Dim i As Integer
    For i = 0 To UBound(line) - 1
        data(i, 0) = Split(line(i), ",")(0)
        data(i, 1) = Replace(Split(line(i), ",")(1), """", "")
    Next i
    GetHolidayList = data
End Function
'---------------------------------------------------------------------------------------
' Procedure : getCalendar
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : 引数dで指定した日付を含む月のカレンダーを返す。
' Return    : Variant:7行 7列(0 to 6, 0 to 6)の二次元配列が得られる。
' Return    : shortName はデフォルトで True。
'      短縮した曜日名を使用しないとき False を指定する。
'---------------------------------------------------------------------------------------
'
Public Function GetCalendar(Optional d As Date, Optional shortName As Boolean = True) As Variant
    d = setDate(d)
    Dim yr As Integer, mm As Integer
    yr = Year(d)
    mm = Month(d)
    Dim beginDay As Integer, endDate As Integer
    beginDay = WorksheetFunction.Weekday(DateSerial(yr, mm, 1)) - 1
    endDate = Day(WorksheetFunction.EOMonth(d, 0))
    Dim w(6, 6)
    Dim i As Integer, j As Integer, dayCount As Integer
    For i = 0 To 6
        w(0, i) = WeekdayName(i + 1, shortName)
    Next i
    dayCount = 1
    For i = beginDay To 6
        w(1, i) = DateSerial(yr, mm, dayCount)
        dayCount = dayCount + 1
    Next i
    For i = 2 To 6
        For j = 0 To 6
            w(i, j) = DateSerial(yr, mm, dayCount)
            dayCount = dayCount + 1
            If dayCount > endDate Then GoTo finish
        Next j
    Next i
finish:
    GetCalendar = w
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetDatesOfFixedDay
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : ある月(引数 yr/mm)の特定の曜日(wd : 1~7=日~土)の日付をすべて取得する
' Return    : Variant:日付が格納された一次元配列を返す
'---------------------------------------------------------------------------------------
'
Public Function GetDatesOfFixedDay(wd As Integer, Optional yr As Integer, Optional mm As Integer) As Variant
    If yr = 0 Then yr = Year(Date)
    If mm = 0 Then mm = Month(Date)
    If wd > 7 Or yr < 1900 Or mm > 12 Or mm < 1 Then
        Err.Raise 6
        Exit Function
    End If
    Dim endDate As Integer
    endDate = Day(WorksheetFunction.EOMonth(DateSerial(yr, mm, 1), 0))
    Dim d() As Variant
    Dim td As Date, tdd As Integer, i As Integer, cnt As Integer
    For i = 1 To endDate
        td = DateSerial(yr, mm, i)
        tdd = WorksheetFunction.Weekday(td)
        If tdd = wd Then
            ReDim Preserve d(cnt)
            d(cnt) = td
            cnt = cnt + 1
        End If
    Next i
    GetDatesOfFixedDay = d
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetDatesOfFixedWeek
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : ある月(引数 yr/mm)の第weekNum週の日付をすべて取得する
' Return    : Variant:日付が格納された一次元配列を返す
'---------------------------------------------------------------------------------------
'
Public Function GetDatesOfFixedWeek(weekNum As Integer, Optional yr As Integer, Optional mm As Integer) As Variant
    If yr = 0 Then yr = Year(Date)
    If mm = 0 Then mm = Month(Date)
    If weekNum < 1 Or weekNum > 6 Or yr < 1900 Or mm < 1 Or mm > 12 Then
        Err.Raise 6
        Exit Function
    End If
    Dim d As Date
    d = DateSerial(yr, mm, 1)
    Dim data As Variant
    data = GetCalendar(d)
    Dim wd(6) As Date
    Dim i As Integer
    For i = 0 To 6
        wd(i) = DateSerial(yr, mm, data(weekNum, i))
    Next i
    GetDatesOfFixedWeek = wd
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetAnnualDateList
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : 指定された年の日付のリストを作成する
' Return    : Variant
'---------------------------------------------------------------------------------------
'
Public Function GetAnnualDateList(yr As Integer, Optional direction As Integer = xlVertical) As Variant
    If yr < 1900 Then
        Err.Raise 6
        Exit Function
    End If
    Dim endDate As Integer
    Dim hD(11, 30)
    Dim vD(30, 11)
    Dim i As Integer, j As Integer, m As Integer, d As Integer
    For i = 1 To 12
        endDate = Day(WorksheetFunction.EOMonth(DateSerial(yr, i, 1), 0))
        For j = 1 To endDate
            m = i - 1
            d = j - 1
            hD(m, d) = DateSerial(yr, i, j)
            vD(d, m) = DateSerial(yr, i, j)
        Next j
    Next i
    If direction = xlHorizontal Then
        GetAnnualDateList = hD
    ElseIf direction = xlVertical Then
        GetAnnualDateList = vD
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetMonthDatesList
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : 指定されたyr年mm月の日付のリストを作成する
' Return    : Variant:日付が格納された一次元配列を返す
'---------------------------------------------------------------------------------------
'
Public Function GetMonthDatesList(Optional yr As Integer, Optional mm As Integer) As Variant
    If yr = 0 Then yr = Year(Date)
    If mm = 0 Then mm = Month(Date)
    If yr < 1900 Or mm < 1 Or mm > 12 Then
        Err.Raise 6
        Exit Function
    End If
    Dim data As Variant
    data = GetAnnualDateList(yr)
    Dim md() As Date
    Dim endDate As Integer
    endDate = Day(WorksheetFunction.EOMonth(DateSerial(yr, mm, 1), 0)) - 1
    ReDim Preserve md(endDate)
    Dim i As Integer
    For i = 0 To endDate
        md(i) = data(i, mm - 1)
    Next i
    GetMonthDatesList = md
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetGestationalWeeks
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Integer
'---------------------------------------------------------------------------------------
'
Public Function GetGestationalWeeks(vDate As Date, Optional aDate As Date) As Integer
    aDate = setDate(aDate)
    Dim w As Integer
    w = WorksheetFunction.RoundDown(DiffDays(vDate, aDate) / 7, 0)
    If w < 0 Then
        Call Err.Raise(54889, , "????")
        Exit Function
    ElseIf w > 45 Then
        Call Err.Raise(889, , "母体に負担が大きすぎます。すぐに病院へ。")
        Exit Function
    End If
    GetGestationalWeeks = w
End Function
'---------------------------------------------------------------------------------------
' Procedure : getCsvFromWeb
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   : ネット上のCSVデータを文字列として取得する
' Return    : String:全文一括の文字列
'---------------------------------------------------------------------------------------
'
Private Function getCsvFromWeb(url As String) As String
    Dim HTTP As Object
    Dim res As String
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    HTTP.Open "GET", url, False     'false:同期通信 すべての応答が返ってから次へ
    HTTP.Send   '実際に要求を送信
    If HTTP.Status = 200 Then   'エラーページが返ってくるので常に200
        res = HTTP.responseText
    End If
    Set HTTP = Nothing
    getCsvFromWeb = res
End Function
'---------------------------------------------------------------------------------------
' Procedure : setDate
' Author    : Plus One Software
' Date      : 2018/04/27
' Purpose   :
' Return    : Date
'---------------------------------------------------------------------------------------
'
Private Function setDate(d As Date) As Date
    If d = "0:00:00" Then
        d = Date
    End If
    setDate = d
End Function

DateCalculatorClass 使い方

組み込み

クラス(ユーザー定義型)ですので、VBEでクラスモジュールを追加してから、上記のコードをバシッとコピーペーストしてください。

あとは標準モジュールの中で使うのもよし、フォームモジュールの中で使うのもよし。お好きにやって下さいまし。

インスタンス化

通常のクラスとしてインスタンス化してあげてください。

書式

Dim 変数名 As クラスオブジェクト名
Set 変数名 = New クラスオブジェクト名

 

コード例

Dim cal As DateCalculatorClass
Set cal = New DateCalculatorClass

使い方

後述する機能から使いたいものを選んで適所に用います。

プロパティは取得のみ可能。引数については、取るもの、取らないもの、省略可能なものなどあります。詳細は後述の説明を参照してください。

書式

変数(インスタンス)名.プロパティ(引数1, 引数2, 引数3, 引数4)

変数(インスタンス)名.関数(引数1, 引数2, 引数3)

コード例

    Dim cal As DateCalculatorClass
    Set cal = New DateCalculatorClass
    ' 2000年2月1日を含む月(2000年2月のこと)のカレンダーを作成する
    Dim data
    data = cal.GetCalendar("2000/2/1")
    Range("A1:G7") = data
    ' 2008年8月8日の曜日を、日本語の省略形の括弧付きで求める
    Debug.Print cal.Weekday(aDay:="2008/8/8", withBrackets:=True, fullString:=False, withEnglish:=False)
    ' 1991年8月11日生まれの人の、2006年12月13日付の年齢を求める
    Debug.Print cal.HowOld(birthday:="1991/8/11", aDate:="2006/12/13")
    ' 2018年2月8日を起算日として、2018年6月27日時点での妊娠週数を求める
    Debug.Print cal.GetGestationalWeeks("2018/2/8", "2018/6/27")
    Set cal = Nothing

実行結果

インスタンスの破棄

通常通りです。

書式

Set 変数名 = Nothing

コード例

    Set cal = Nothing

DateCalculatorClass のプロパティ

このクラスのプロパティはすべて取得のみ可能です。設定することはできません。

Today:今日の日付

現在の日付を今日の日付として返します。

書式

日付型変数 = 変数(インスタンス)名.Today

コード例

    '今日の日付
    Debug.Print "今日", cal.Today

Yesterday:昨日の日付

昨日の日付を返します。

書式

日付型変数 = 変数(インスタンス)名.Yesterday( [aDay] )

  • 引数 aDay:昨日を求める基準となる日付。日付型。省略した場合は今日の日付を基準とする。

コード例

    '昨日の日付
    Debug.Print "昨日", cal.Yesterday
    Debug.Print "2010/10/8 の昨日", cal.Yesterday("2010/10/8")

Tomorrow:明日の日付

明日の日付を返します。

書式

日付型変数 = 変数(インスタンス)名.Tomorrow( [aDay] )

  • 引数 aDay:明日を求める基準となる日付。日付型。省略した場合は今日の日付を基準とする。

コード例

    '明日の日付
    Debug.Print "明日", cal.Tomorrow
    Debug.Print "2010/10/8 の明日", cal.Tomorrow("2010/10/8")

Weekday:曜日

指定された日付が何曜日であるかを返します。

書式

文字列型変数 = 変数(インスタンス)名.Weekday( [aDay, withBrackets, fullString, withEnglish] )

  • 引数 aDay:曜日を求める日付。日付型。省略した場合は今日に設定される。
  • 引数 withBrackets:括弧付きにするかどうか。真偽値。省略した場合は False。
  • 引数 fullString:省略しない曜日名を返すかどうか。真偽値。省略した場合は False。
  • 引数 withEnglish:英語の曜日名で返すかどうか。真偽値。省略した場合は False。

コード例

    ' 2008年8月8日の曜日を、日本語の省略形の括弧付きで求める
    Debug.Print "今日の曜日", cal.Weekday()
    Debug.Print "2008/8/8 の曜日", cal.Weekday(aDay:="2008/8/8", withBrackets:=True, fullString:=False, withEnglish:=False)
    Debug.Print "2008/8/8 の曜日", cal.Weekday("2008/8/8", , True)
    Debug.Print "2008/8/8 の曜日", cal.Weekday("2008/8/8", , , True)
    Debug.Print "2008/8/8 の曜日", cal.Weekday(aDay:="2008/8/8", fullString:=True, withEnglish:=True)

DaysAfter:xx日後

指定された日付のxx日後の日付を返します。

書式

整数型変数 = 変数(インスタンス)名.DaysAfter( [aDay] )

  • 引数 aDay:基準となる日付。日付型。省略した場合は今日の日付を基準とする。

コード例

    Debug.Print "今日から30日後", cal.DaysAfter(30)
    Debug.Print "2018/4/5 から12日後", cal.DaysAfter(12, "2018/4/5")

DaysBefore:xx日前

指定された日付のxx日前の日付を返します

書式

整数型変数 = 変数(インスタンス)名.DaysBefore( [aDay] )

  • 引数 aDay:基準となる日付。日付型。省略した場合は今日の日付を基準とする。

コード例

    'X日前
    Debug.Print "今日から30日前", cal.DaysBefore(30)
    Debug.Print "2018/4/5 から12日前", cal.DaysBefore(12, "2018/4/5")

DiffYears:2つの日付間の年差

指定された2つの日付間の年差を返します。

書式

整数型変数 = 変数(インスタンス)名.DiffYears( d1[, d2] )

  • 引数 d1:求める先または前の日付。日付型。必須。
  • 引数 d2:基準とする日付。日付型。省略した場合は今日を基準とする。

コード例

    '年差
    Debug.Print "2015/11/3 と今日の年差", cal.DiffYears("2015/11/3")
    Debug.Print "2010/1/1 と 2018/4/5 の年差", cal.DiffYears("2010/1/1", "2018/4/5")

DiffMonths:2つの日付間の月差

指定された2つの日付間の月差を返します。

書式

整数型変数 = 変数(インスタンス)名.DiffMonths( d1[, d2] )

  • 引数 d1:求める先または前の日付。日付型。必須。
  • 引数 d2:基準とする日付。日付型。省略した場合は今日を基準とする。

コード例

    '月差
    Debug.Print "2017/11/3 と今日の月差", cal.DiffMonths("2017/11/3")
    Debug.Print "2017/1/1 と 2018/4/5 の月差", cal.DiffMonths("2017/1/1", "2018/4/5")

DiffWeeks:2つの日付間の週差

指定された2つの日付間の週差を返します。

書式

整数型変数 = 変数(インスタンス)名.DiffWeeks( d1[, d2] )

  • 引数 d1:求める先または前の日付。日付型。必須。
  • 引数 d2:基準とする日付。日付型。省略した場合は今日を基準とする。

コード例

    '週差
    Debug.Print "2018/1/3 と今日の週差", cal.DiffWeeks("2018/1/3")
    Debug.Print "1978/11/1 と 1980/4/5 の週差", cal.DiffWeeks("1978/11/1", "1980/4/5")

DiffDays:2つの日付間の日差

指定された2つの日付間の日差を返します。

書式

整数型変数 = 変数(インスタンス)名.DiffDays( d1[, d2] )

  • 引数 d1:求める先または前の日付。日付型。必須。
  • 引数 d2:基準とする日付。日付型。省略した場合は今日を基準とする。

コード例

    '日差
    Debug.Print "2018/1/1 と今日の日差", cal.DiffDays("2018/1/1")
    Debug.Print "2018/1/1 と 2018/4/5 の日差", cal.DiffDays("2018/1/1", "2018/4/5")

EOMonth:月末の日付

月末の日付を返します。

書式

日付型変数 = 変数(インスタンス)名.EOMonth( [aDay, months] )

  • 引数 aDay:基準となる日付。日付型。省略した場合は今日を基準とする。
  • 引数 months:基準日から加算する月数。整数型。正の数でxxヶ月後の月末、負の数でxxヶ月前の月末日付を求めることが可能。省略した場合は0。

コード例

    '月末の日付
    Debug.Print "今日を含む月(今月)の月末", cal.EOMonth()
    Debug.Print "2014/9/4 を含む月の月末", cal.EOMonth("2014/9/4")
    Debug.Print "2014/9/4 から6か月後の月末", cal.EOMonth("2014/9/4", 6)

DateCalculatorClass の関数

日付やカレンダー関連の便利なデータを簡単に得ることができます。

HowOld:年齢を取得する

誕生日を考慮した年齢を返します。

書式

変数(インスタンス)名.HowOld( birthday[, aDate] )

  • 引数 birthday:誕生日を指定します。日付型。必須。
  • 引数 aDate:年齢を計算する日付を指定します。日付型。省略した場合は今日。

返値

整数型:Integer

誕生日を考慮するので、例えば引数birthdayに1990年5月1日を指定し、引数aDateに2010年4月30日を指定した場合は「19」、2010年5月1日を指定した場合は「20」が返されます。

コード例

    ' 1991年8月11日生まれの人の、2006年12月13日付の年齢を求める
    Debug.Print "1991年8月11日生まれの人の今の年齢", cal.HowOld("1991/8/11")
    Debug.Print "1991年8月11日生まれの人の、2006年12月13日付の年齢", cal.HowOld(birthday:="1991/8/11", aDate:="2006/12/13")

IsHoliday:祝日であるか

指定された日付が祝日であるかどうか。祝日であれば祝日名を返します。

書式

変数(インスタンス)名.IsHoliday( d )

  • 引数 d:日付型。必須。

返値

バリアント型:Variant

バリアント型の値を返します。
祝日であれば「こどもの日」などの祝日名を、祝日でなければ「False」のブール値を返します。

コード例

    '祝日であるか
    Debug.Print "2018/8/11 が祝日かどうか", cal.IsHoliday("2018/8/11")
    Debug.Print "2018/7/5 が祝日かどうか", cal.IsHoliday("2018/7/5")

GetHolidayList:祝日一覧を取得する

去年、今年、来年の3ヶ年分の祝日一覧を返します。

祝日のデータは「https://holidays-jp.github.io/api/v1/date.csv」より取得しています。インターネット接続環境が必要です。

書式

変数(インスタンス)名.GetHolidayList( )

返値

バリアント型:Variant

「祝日の日付 , 祝日名」という形式のバリアント型二次元配列を返します。

コード例

    '祝日リスト(去年、今年、来年分)
    ' https://holidays-jp.github.io/api/v1/date.csv より取得
    Dim data1
    data1 = cal.GetHolidayList()
    Sheets(1).Range("A1:B" & UBound(data1) + 1) = data1

GetCalendar:カレンダーを取得する

指定された日付を含む月のカレンダーを返します。

書式

変数(インスタンス)名.GetCalendar( [d , shortName] )

  • 引数 d:作成したい年月を含む日付(日は何日でも良い)を指定します。日付型。省略した場合は今月のカレンダーを返す。
  • 引数 shortName:曜日名を短い形式にするか、長い形式にするかの指定です。真偽値。省略するとTrue(短い曜日形式)

返値

バリアント型:Variant

7行7列のバリアント型の二次元配列を返します。

コード例

    ' 2000年2月1日を含む月(2000年2月のこと)のカレンダーを作成する
    Dim data2
    data2 = cal.GetCalendar("2000/2/1")
    With Sheets(2).Range("A1:G7")
        .NumberFormatLocal = "d"
        .Value = data2
    End With
    data2 = cal.GetCalendar("2001/2/1", True)
    With Sheets(2).Range("I1:O7")
        .NumberFormatLocal = "d"
        .Value = data2
    End With

GetDatesOfFixedDay:月内の特定曜日の日付を取得する

指定された年月の指定された曜日の日付をすべて返します。例えば、「2018年9月のすべての土曜日の日付」を取得することができます。

書式

変数(インスタンス)名.GetDatesOfFixedDay( wd[, yr, mm] )

  • 引数 wd:求める曜日、日曜〜土曜を1〜7の番号で指定します。整数型。必須。
  • 引数 yr:対象となる年を指定します。整数型。省略した場合は今年。
  • 引数 mm:対象となる月を指定します。整数型。省略した場合は今月。

返値

バリアント型:Variant

日付が格納された一次元配列を返します。

コード例

    '月内の特定曜日の日付リスト(2016年12月の日曜日のリスト)
    Dim data3
    data3 = cal.GetDatesOfFixedDay(1, 2016, 12)
    Debug.Print "2016年12月の日曜日のリスト"
    Dim i
    For i = LBound(data3) To UBound(data3)
        Debug.Print data3(i),
    Next i
    Debug.Print

GetDatesOfFixedWeek:第x週の日付をすべて取得する

指定された番号の週の日付をすべて返します。

書式

変数(インスタンス)名.GetDatesOfFixedWeek(weekNum[,yr, mm] )

  • 引数 weekNum:週番号を指定します。整数型。必須。
  • 引数 yr:対象となる年を指定します。整数型。省略した場合は今年。
  • 引数 mm:対象となる月を指定します。整数型。省略した場合は今月。

返値

バリアント型:Variant

日付が格納された一次元配列を返します。

コード例

    '月内の特定週の日付リスト(2016年12月の第2週のリスト)
    Dim data5
    data5 = cal.GetDatesOfFixedWeek(2, 2016, 12)
    Debug.Print "2016年12月の第2週のリスト"
    For i = LBound(data5) To UBound(data5)
        Debug.Print data5(i),
    Next i
    Debug.Print

GetAnnualDateList:年間のすべての日付リストを取得する

指定された年のすべての日付を返します。

書式

変数(インスタンス)名.GetAnnualDateList(yr [, direction] )

  • 引数 yr:年を指定します。整数型。必須。
  • 引数 direction:縦長のリスト(月を横に、日付を縦に並べる)にするか、横長のリスト(月を縦に、日付を横に並べる)にするかを、xlVertical、xlHorizontalのエクセル組み込み定数で指定します。省略するとxlVertical。

返値

バリアント型:Variant

バリアント型の二次元配列を返します。

コード例

    '指定年のすべての日付リスト(2018年のリストを縦方向と横方向で)
    Dim data4
    data4 = cal.GetAnnualDateList(2018)
    Sheets(3).Range("A1:L" & UBound(data4) + 1) = data4
    Erase data4
    data4 = cal.GetAnnualDateList(2018, xlHorizontal)
    Sheets(4).Range("A1:AE" & UBound(data4) + 1) = data4

GetMonthDatesList:月の日付リストを取得する

指定された年月の日付のリストを返します。

書式

変数(インスタンス)名.GetMonthDatesList( [yr, mm] )

  • 引数 yr:対象となる年を指定します。整数型。省略した場合は今年。
  • 引数 mm:対象となる月を指定します。整数型。省略した場合は今月。

返値

バリアント型:Variant

日付が格納された一次元配列を返します。

コード例

    '指定月の日付リスト(2011年2月のリスト)
    Dim data6
    data6 = cal.GetMonthDatesList(2011, 2)
    Debug.Print "今月の日付リスト"
    For i = LBound(data6) To UBound(data6)
        Debug.Print data6(i),
    Next i
    Debug.Print

GetGestationalWeeks:妊娠週数を取得する

指定された日付間の妊娠週数を返します。

書式

変数(インスタンス)名.GetGestationalWeeks(vDate[, aDate] )

  • 引数 vDate:起算日を指定します。日付型。必須。
  • 引き数 aDate:週数を求める日付を指定します。日付型。省略すると今日。

返値

整数型:Integer

整数型の値を返します。

コード例

    ' 妊娠週数を求める
    Debug.Print "2018年2月8日を起算日とした2018年6月27日時点での妊娠週数", cal.GetGestationalWeeks("2018/2/8", "2018/6/27")

【Excel VBA】アンケートを集計するマクロ

Yahoo!知恵袋をツラツラと見ていると、なんだかとっても困っていそうな人を見つけてしまった。

回答しようとしたけれど、なぜかYahooからサーバーのエラーが返ってきて回答できなかったのでこちらに掲載しておこうと思う。

元ネタはこちら。

エクセルデータの集計について

なんでも300件ほどの相手先にアンケートのエクセルファイルを配布したのだけど、回答の集計シートを作るのを忘れて配布したとか。
おそらく本来ならそれぞれのブック内でそのブックの集計はされているので、データを全体の集計表にペーストすればおしまい、という話だったのだろう。

これは大変な困りごとである。助けなければ…。

以下のソースを新しいブックの標準モジュールに貼り付けて実行するといい。ただし質問の内容だけでは不明な点も多いので、こちらでいくつかの基本的な仕様は勝手に決めてある。違う条件で動作させるためにはさらに改良は必要だろう。

  • 各アンケートのファイル形式は、コントロールを使用しているとのことなので「マクロ有効ブック」と仮定した。従って拡張子は「.xlsm」。
  • 返却された回答ブックはひとつのフォルダにまとめて保存してあるものとした。
  • どんなアンケートかわからないので、こちらで以下のようなアンケートを勝手に作成した。シート上にアクティブx コントロールを配置してある。
  • 集計するシートは3行目に集計の項目名が書いてあり、4行目からデータを落とし込んでいくものとした。
  • ファイルシステムオブジェクトを使っているので、「Microsoft Scripting Runtime」への参照設定をVBEでおこなう必要がある。

 

Option Explicit

Sub CollectAnswers()
    ' 初期設定
    ' 集計表の項目数と回答済みのファイルが保存されているフォルダのパス
    Const ITEMS_UBOUND As Integer = 8
    Dim ANK_PATH As String: ANK_PATH = ThisWorkbook.Path & "\" & "回答済み" & "\"
    ' 集計データを書き込むセル範囲の左上のセル位置(行と列)
    Const START_ROW As Integer = 4
    Const START_COLUMN As Integer = 1
    
    ' 回答済みのファイル数をカウント
    ' 集計表の行数になる
    Dim fso As New FileSystemObject
    Dim fol As Folder
    Set fol = fso.GetFolder(ANK_PATH)
    Dim fileCount As Integer
    fileCount = fol.Files.Count
    Set fol = Nothing
    Set fso = Nothing
    
    Application.ScreenUpdating = False
    
    ' 集計表のもとになる二次元配列
    Dim data
    ReDim data(fileCount - 1, ITEMS_UBOUND)
    
    ' ひとつずつファイルを開いて回答を収集
    ' 回答ファイル名の最後は ank.xlsm の文字が共通していると仮定
    Dim tmpBookName As String
    tmpBookName = Dir(ANK_PATH & "*ank.xlsm")
    Dim cnt As Integer
    Do While tmpBookName <> ""
        Workbooks.Open (ANK_PATH & tmpBookName)
        ' ブックを開いた時には回答シートがアクティブになっていると仮定
        With ActiveSheet
            ' テキストボックスはそのまま取り込む
            data(cnt, 0) = .TextBox1.Text
            ' はい/いいえのラジオボタンは1か0であらわす
            If .OptionButton1.Value Then
                data(cnt, 1) = 1
            ElseIf .OptionButton2.Value Then
                data(cnt, 1) = 0
            End If
            ' チェックボックスそれぞれを集計項目として1か0であらわす
            Dim i As Integer
            For i = 0 To 5
                data(cnt, i + 2) = CInt(.OLEObjects("CheckBox" & i + 1).Object.Value) ^ 2
            Next i
            ' テキストボックス
            data(cnt, 8) = .TextBox2.Text
        End With
        ActiveWorkbook.Close
        tmpBookName = Dir()
        cnt = cnt + 1
    Loop
    
    ' 二次元配列をセル範囲に落とす
    Range(Cells(START_ROW, START_COLUMN), Cells(START_ROW + fileCount - 1, START_COLUMN + ITEMS_UBOUND)) = data
    
    Application.ScreenUpdating = True
End Sub

 

さて、うまくいくといいが…。

【Excel VBA】数式が入力されているセル範囲を列挙する

シート状の数式が入力されているセルをすべて知りたい、またはそれらをチェックするときに使えるマクロ。

Option Explicit

Sub 数式が入力されているセル範囲を列挙する()
    Dim targetRange As Range
    Set targetRange = Selection.CurrentRegion
    
    Dim str As String
    str = targetRange.SpecialCells(xlCellTypeFormulas).Address
    str = Replace(str, "$", "")
'    str = Replace(str, ":", "~")
    
    Dim data
    data = Split(str, ",")
    
    Dim i As Integer
    For i = LBound(data) To UBound(data)
        Debug.Print data(i)
'        Range(data(i)).Select
    Next i
    
    Set targetRange = Nothing
End Sub

 

単に範囲を知りたいだけの場合は、上記の10行目のコメントを外すと人間的には少しわかりやすい形で知ることができます。

また、チェックのために範囲選択をさせて場所を特定したい場合は、18行目のコメントを外した上で、19行目にでもブレイクポイントをつけて実行すると、いちいちマクロの実行が一時停止するので、その状態でゴニョゴニョすればよろしい。