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


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

先日来からの自作クラスのお話で恐縮だが、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 を使ってカレンダーを作ってみる


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

先日アップした 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】日付を扱いやすくするクラス


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

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

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

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

【2018年4月30日追記】

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

'---------------------------------------------------------------------------------------
' 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】数式が入力されているセル範囲を列挙する


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

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

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行目にでもブレイクポイントをつけて実行すると、いちいちマクロの実行が一時停止するので、その状態でゴニョゴニョすればよろしい。

 

【Excel VBA】結合セルを詰めてコピーペーストするマクロ


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

近頃はマクロ制作のお仕事をよくいただきます。ありがとうございます。

先日いただいたお仕事で資料としてお預かりしたエクセルブックが「エクセル方眼紙」になっていて、セルのデータをコピーペーストしようとすると空欄が盛大に入ってくるので、なんとも扱いにくかったのでこのマクロを作りました。

エクセル方眼紙で作成されたものは大抵セル結合がたっぷり入っています。

そのままコピーしてペーストするとこの通り空欄だらけで、貼り付け先に入力しておいたデータを消してしまうことも…。

上の例のように3列のつもりで扱うと大変なことになってしまいます。

そこでマクロ。まずはメインのコード。

Sub Main()
    
    Dim add
    add = Split(Replace(Selection.Address, "$", ""), ":")
    
    Dim r, col
    r = getMergeRowsCount(add)
    col = getMergeColumnsCount(add)
    
    Dim rowCnt, colCnt
    rowCnt = UBound(r)
    colCnt = UBound(col)
    
    Debug.Print "area start address: ", add(0)
    Debug.Print "area end address: ", add(1)
    Debug.Print "rows count: ", rowCnt
    Debug.Print "columns count: ", colCnt
    Debug.Print
    
    Dim data
    ReDim data(rowCnt, colCnt)
    Dim i, j
    For i = 0 To UBound(r)
        For j = 0 To UBound(col)
            data(i, j) = Cells(r(i), col(j)).Value
        Next j
    Next i
    
    Call putData(data)
End Sub

 

メインから呼び出している3つのプロシージャ。2つは結合の主体となっているセルの行列番号を特定するためのもの。最後の一つはとりあえず新しいシートを追加してデータを貼り付けたのち、それをコピーしてクリップボードに取り込むためのもの。

Private Function getMergeRowsCount(add) As Variant
    Dim r
    ReDim r(0)
    r(0) = Range(add(0)).Row
    Dim inc, j: j = 0
    Do While r(j) <= Range(add(1)).Row
        Debug.Print "rows " & j; ": " & r(j)
        inc = Cells(r(j), Range(add(0)).Column).MergeArea.Rows.Count
        j = j + 1
        ReDim Preserve r(j)
        r(j) = r(j - 1) + inc
    Loop
    If UBound(r) > j - 1 Then
        ReDim Preserve r(j - 1)
    End If
    getMergeRowsCount = r
End Function

 

Private Function getMergeColumnsCount(add) As Variant
    Dim col
    ReDim col(0)
    col(0) = Range(add(0)).Column
    Dim inc, i: i = 0
    Do While col(i) <= Range(add(1)).Column
        Debug.Print "columns " & i; ": " & col(i)
        inc = Cells(Range(add(0)).Row, col(i)).MergeArea.Columns.Count
        i = i + 1
        ReDim Preserve col(i)
        col(i) = col(i - 1) + inc
    Loop
    If UBound(col) > i - 1 Then
        ReDim Preserve col(i - 1)
    End If
    getMergeColumnsCount = col
End Function

 

Private Sub putData(data)
    Worksheets.add
    Dim myName As String
    myName = ActiveSheet.Name
    With Sheets(myName)
        .Activate
        Dim nr, ncol
        nr = Selection.Row
        ncol = Selection.Column
        Dim myRange As Range
        Set myRange = .Range(.Cells(nr, ncol), .Cells(nr + UBound(data, 1), ncol + UBound(data, 2)))
        With myRange
            .Value = data
            .Copy
        End With
    End With
'    Application.DisplayAlerts = False
'    Sheets(myName).Delete
'    Application.DisplayAlerts = True
End Sub

 

最後のところで追加したシートを削除しておこうと思ったんですけど、コピーした後に余計なことをするとコピーペーストモードが解除されてしまって貼り付けできないので、仕方なくそのままです。どこかにデータを貼り付け後に手動でシート削除してください(笑)
このマクロを使うと先ほどの上の画像の貼り付け結果もこの通り。

マクロを使って普通になってくれたデータ

サンプルのファイルはこちらからダウンロードできます。

サンプルファイルのダウンロード