[[20150522143904]]　『年度でなくて日付を転記するには』（さんま）　ページの最後に飛ぶ

『年度でなくて日付を転記するには』（さんま）

下記のＶＢＡはセルＢ列に年度の数字を入れている場合のＶＢＡになります。
それをＢ列に日付(例：2015/4/18）を入れて同じように年度ごとに分けられるよう作動させるにはどこを直したらよいのでしょうか？

Sub 日付転記()

    Dim a, x, i As Long, ii As Long, n As Long, temp, txt
    Dim minYear As Long, maxYear As Long
    With Cells(1).CurrentRegion
        a = .Value: n = 1
        minYear = Application.Min(.Columns(2))
        maxYear = Application.Max(.Columns(2))
        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + maxYear - minYear + 2)
        For i = 2 To UBound(a, 2) - 1
            a(n, i) = minYear + i - 2 & "年"
        Next
        a(n, UBound(a, 2)) = "番号"
        With CreateObject("Scripting.Dictionary")
            .CompareMOde = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1: .Item(a(i, 1)) = n: a(n, 1) = a(i, 1)
                End If
                temp = a(i, 2): a(i, 2) = ""
                txt = a(i, 3): a(i, 3) = ""
                a(.Item(a(i, 1)), temp - minYear + 2) = temp
                a(.Item(a(i, 1)), UBound(a, 2)) = txt
            Next
        End With
        With .Offset(, .Columns.Count + 1).Cells(1).Resize(n, UBound(a, 2))
            .CurrentRegion.ClearContents
            .Value = a
            .Columns.AutoFit
        End With
    End With
End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 １．年度初めは、いつなんですか？

 　　※世間一般では、1月1日か、4月1日にする人が多いとは思いますけど。

 ２．B列は全部日付になるんですか？
 　　それとも一部のデータは年度のままなんですか？

（半平太） 2015/05/22(金) 15:41

半平太様、ありがとうございます。
１．年度はじめは　4月1日になります。

２．Ｂ列は全て日付にします。

宜しくお願い致します。

（さんま） 2015/05/22(金) 15:51

 横から失礼します。

 Sub 日付転記()
    Dim a, x, i As Long, ii As Long, n As Long, temp, txt
    Dim minYear As Long, maxYear As Long
    With Cells(1).CurrentRegion
        a = CvYear(.Value): n = 1
        minYear = Application.Min(a)
        maxYear = Application.Max(a)
        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + maxYear - minYear + 2)
        For i = 2 To UBound(a, 2) - 1
            a(n, i) = minYear + i - 2 & "年"
        Next
        a(n, UBound(a, 2)) = "番号"
        With CreateObject("Scripting.Dictionary")
            .CompareMOde = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1: .Item(a(i, 1)) = n: a(n, 1) = a(i, 1)
                End If
                temp = a(i, 2): a(i, 2) = ""
                txt = a(i, 3): a(i, 3) = ""
                a(.Item(a(i, 1)), temp - minYear + 2) = temp
                a(.Item(a(i, 1)), UBound(a, 2)) = txt
            Next
        End With
        With .Offset(, .Columns.Count + 1).Cells(1).Resize(n, UBound(a, 2))
            .CurrentRegion.ClearContents
            .Value = a
            .Columns.AutoFit
        End With
    End With
 End Sub

 Function CvYear(Dts)
    Dim x, y, cv()
    For x = 1 To UBound(Dts)
        For y = 1 To 2
            If IsDate(Dts(x, y)) Then Dts(x, y) = Year(DateAdd("m", -3, Dts(x, y)))
        Next y
    Next x
    CvYear = Dts
 End Function

 日付から年度に変換するユーザー定義関数を作成しています。
 B列はどちらでもいいようにしてあります。

（ろっくん） 2015/05/22(金) 16:12

 ※今までの処理は正しかった、と云う前提です。　
 ※既存の処理の細部はチェックしておりません　m(__)m

 aに格納されている日付データを最初から年度に変換してしまう案です。

 ＞        minYear = Application.Min(.Columns(2))
 ＞        maxYear = Application.Max(.Columns(2))

 ↓上記2文を下記9文に変更

         minYear = CLng(Format(Application.Min(.Columns(2)) + 275, "YYYY")) - 1
         maxYear = CLng(Format(Application.Max(.Columns(2)) + 275, "YYYY")) - 1

         If minYear < 1970 Then
             MsgBox "日付データが古すぎませんか？"
             Exit Sub
         End If

         For i = 2 To UBound(a)　’日付を年度(4月1日始め）に変換
             a(i, 2) = CLng(Format(a(i, 2) + 275, "YYYY")) - 1
         Next i

（半平太） 2015/05/22(金) 16:44

ろっくん様、半平太様、ありがとうございます。

転記はできましたが、西暦だけでなく月と日にちも転記したいのです。
2015/5/22←のように転記したいです。

↑を2015年の列に明記したいです。

宜しくお願い致します。

（さんま） 2015/05/22(金) 18:35

 あれ？　今までと同じものを作るんじゃないのですかぁ。

 ・・・とすると何を作ればいいのかよく分かりません。

 ※ご提示のプログラムをつぶさに読んだら分かるのかも知れませんが、
 　現在、その気力が涌かないので、私は、ここでドロップアウトさせて頂きます。
 　大変申し訳ありません。　m(__)m

（半平太） 2015/05/22(金) 20:17

半平太さんの修正から、さらに下記の変更でどうでしょうか。

 With Cells(1).CurrentRegion
    a = .Value: n = 1
　↓
 Dim b()    
 With Cells(1).CurrentRegion
     a = .Value: n = 1
     ReDim b(1 To UBound(a, 1))

さらに

 a(.Item(a(i, 1)), temp - minYear + 2) = temp
　↓
 a(.Item(a(i, 1)), temp - minYear + 2) = b(i)

（マナ） 2015/05/22(金) 21:04

ごめんなさい。もう１箇所ありました。

 For i = 2 To UBound(a)　’日付を年度(4月1日始め）に変換
	a(i, 2) = CLng(Format(a(i, 2) + 275, "YYYY")) - 1
 Next i
　↓
 For i = 2 To UBound(a)　’日付を年度(4月1日始め）に変換
        b(i) = a(i, 2)
	a(i, 2) = CLng(Format(a(i, 2) + 275, "YYYY")) - 1
 Next i

（マナ） 2015/05/22(金) 21:25

マナ様ありがとうございます！！！！
変更したところ思っていた通りの事ができました！！！！！
これで作業が早く済みます。
最後までお付き合いありがとうございました。

（さんま） 2015/05/26(火) 18:13

コメント返信：

[ 一覧(最新更新順) ]

[[20150522143904]] 『年度でなくて日付を転記するには』（さんま） ページの最後に飛ぶ

[[20150522143904]]　『年度でなくて日付を転記するには』（さんま）　ページの最後に飛ぶ