エクセルVBA来年成人式を迎える人の抜出

質問

お世話になります。Range("C3")からLastRowまで生年月日が入りRange(”D3")からLastRowまで氏名が入っています。ここから来年成人式を迎える方のデータを新規ブックに抜出したいのですが何方かご教示お願いします

回答No.4

kagakusuki · ベストアンサー

回答No.3

>下記の生年月日で試しましたが、次の成人式に参加する資格のある方はリストの中には見当たりません。と出ました。

　申し訳御座いません。私のミスです。
　本来であれば、
学齢方式では「前回の成人式が行われた年の4月2日」～「次回の成人式が行われる年の4月1日」の期間内に20歳の誕生日を迎えられる方を該当者とし、
年齢方式では「前回の成人の翌日」～「次回の成人の日」の期間内に20歳の誕生日を迎えられる方を該当者
としなければならないところを、誤って
学齢方式では「前回の成人式が行われた年の4月2日」～「次回の成人式が行われる年の4月1日」の期間内に"誕生された方"を該当者とし、
年齢方式では「前回の成人の翌日」～「次回の成人の日」の期間内に"誕生された方"を該当者
としてしまっておりました。
　下記に改善したVBAの構文を記述致しましたので御確認下さい。
　尚、御質問文では

>来年成人式を迎える方のデータを

という事でしたが、下記のVBAのマクロでは「『前回の成人式』の次に行われる成人式に参加される資格のある方」、即ち
学齢方式では「マクロを起動させた日が『4月1日以外の日』の場合は『前回の4月2日』～『次回の4月1日』の期間」、「マクロを起動させた日が『4月1日当日』の場合は『前回の4月2日』～『本日』の期間」に20歳の誕生日を迎えられる方を該当者とし、
年齢方式では「マクロを起動させた日が『成人の日以外の日』の場合は『前回の成人の日』～『次回の成人の日』の期間」、「マクロを起動させた日が『成人の日当日』の場合は『前回の成人の日』～『本日』の期間」に20歳の誕生日を迎えられる方を該当者としております。
　ですから、例えばマクロを起動させた日が1月6日の場合には、「今年の成人の日」がやって来る前なのですから、

>来年成人式を迎える方のデータ

ではなく、「今年成人式を迎える方のデータ」が出力される様になっております。
　また、2月や3月にマクロを起動させた場合には、「今年の成人の日」は過ぎているのに対し、「今年の4月1日」はまだやって来ていないのですから、「学齢方式」を選択した場合は「今年成人式を迎える方のデータ」が、「年齢方式」を選択した場合は「来年成人式を迎える方のデータ」が、それぞれ出力される様になっております。

Sub QNo9259564_エクセルVBA来年成人式を迎える人の抜出()

Const DateColumn As String = "C" '誕生日が入力されている列の列番号
Const NameColumn As String = "D" '氏名が入力されている列の列番号
Const ItemRow As Long = 2 '表の項目名が入力されている行の行番号
Const PasteCell As String = "A1" '表の貼り付け先のセル範囲の中で、左上の隅にあるセルのセル番号
Dim i As Long, LastRow As Long, buf As Variant, myRange As Range _
, myBook As Workbook, TermStart As Date, TermLast As Date

LastRow = Range(DateColumn & Rows.Count).End(xlUp).row
If LastRow <= ItemRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Select Case MsgBox("学齢方式を使用しますか?" _
& vbCrLf & vbCrLf & "学齢方式とは" & vbCrLf _
& "「前回の成人式が行われた年の4月2日」" & vbCrLf _
& "　　～「次回の成人式が行われる年の4月1日」" & vbCrLf _
& "の期間内に20歳の誕生日を迎えられる方を式典の" & vbCrLf _
& "参加対象にする方式です。" & vbCrLf & vbCrLf _
& "その他の方式としては年齢方式があり、こちらは" & vbCrLf _
& "「前回の成人の日の翌日」～「次回の成人の日」" & vbCrLf _
& "の期間内に20歳の誕生日を迎えられる方を式典の" & vbCrLf _
& "参加対象にする方式です。" & vbCrLf & vbCrLf & vbCrLf _
& "[はい] : 学齢方式で式典参加者を選定します" & vbCrLf _
& "[いいえ] : 年齢方式で式典参加者を選定します" & vbCrLf _
& "[キャンセル] : 処理を中止してマクロを終了します" _
, vbYesNoCancel + vbQuestion, "選定方式選択")
Case vbYes
buf = Year(Date) + (Date < DateSerial(Year(Date), 4, 2))
TermStart = DateSerial(buf - 20, 4, 2)
TermLast = DateSerial(buf - 19, 4, 1)
Case vbNo
buf = Year(Date) + (Date < DateSerial(Year(Date), 1, 16 _
- Weekday(DateSerial(Year(Date), 1, 14), vbMonday)))
TermStart = DateSerial(buf - 20, 1, 16 _
- Weekday(DateSerial(buf, 1, 14), vbMonday))
TermLast = DateSerial(buf - 19, 1, 15 _
- Weekday(DateSerial(buf + 1, 1, 14), vbMonday))
Case vbCancel
Exit Sub
End Select

Set myRange = Range(DateColumn & ItemRow & "," & NameColumn & ItemRow)
For i = ItemRow + 1 To LastRow
buf = Range(DateColumn & i).Value
If buf >= TermStart And buf <= TermLast Then _
Set myRange = Union(myRange, Range(DateColumn & i & "," & NameColumn & i))
Next i
If Intersect(myRange, Range(DateColumn & ItemRow + 1 & ":" & NameColumn & LastRow)) Is Nothing Then
MsgBox "次の成人式に参加する資格のある方はリストの中には見当たりません。" _
& vbCrLf & "マクロを終了します。", vbInformation, "該当者無し"
Else

With Application
buf = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.ScreenUpdating = False
.Calculation = xlManual
End With

Set myBook = Workbooks.Add
myRange.Copy
With myBook.Sheets(1).Range(PasteCell)
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
End With

With Application
.CutCopyMode = False
.SheetsInNewWorkbook = buf
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End If

End Sub

お礼

処理できました。感激です　私にはまだまだ未熟でこのような構文を書けるには程遠いですが少しでも近づけるように勉強します、有難うございました。

回答No.3

kagakusuki

下記のVBAのマクロでは如何でしょうか。

Sub QNo9259564_エクセルVBA来年成人式を迎える人の抜出()

Const DateColumn As String = "C" '誕生日が入力されている列の列番号
Const NameColumn As String = "D" '氏名が入力されている列の列番号
Const ItemRow As Long = 2 '表の項目名が入力されている行の行番号
Const PasteCell As String = "A1" '表の貼り付け先のセル範囲の中で、左上の隅にあるセルのセル番号
Dim i As Long, LastRow As Long, buf As Variant, myRange As Range _
, myBook As Workbook, TermStart As Date, TermLast As Date

LastRow = Range(DateColumn & Rows.Count).End(xlUp).row
If LastRow <= ItemRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Select Case MsgBox("学齢方式を使用しますか?" & vbCrLf & vbCrLf _
& "学齢方式とは" & vbCrLf _
& "「前回の成人式が行われた年の4月2日」" & vbCrLf _
& "　　～「次回の成人式が行われる年の4月1日」" & vbCrLf _
& "の期間内に成人される方を式典参加の対象にする方式です。" _
& vbCrLf & vbCrLf _
& "その他の方式としては年齢方式があり、こちらは" & vbCrLf _
& "「前回の成人の日」～「次回の成人の日」" & vbCrLf _
& "の期間内に成人される方を式典参加の対象にする方式です。" _
& vbCrLf & vbCrLf & vbCrLf _
& "[はい] : 学齢方式で式典参加者を選定します" & vbCrLf _
& "[いいえ] : 年齢方式で式典参加者を選定します" & vbCrLf _
& "[キャンセル] : 処理を中止してマクロを終了します" _
, vbYesNoCancel + vbQuestion, "選定方式選択")
Case vbYes
buf = Year(Date) + (Date < DateSerial(Year(Date), 4, 2))
TermStart = DateSerial(buf, 4, 2)
TermLast = DateSerial(buf + 1, 4, 1)
Case vbNo
buf = Year(Date) + (Date < DateSerial(Year(Date), 1, 16 _
- Weekday(DateSerial(Year(Date), 1, 14), vbMonday)))
TermStart = DateSerial(buf, 1, 16 _
- Weekday(DateSerial(buf, 1, 14), vbMonday))
TermLast = DateSerial(buf + 1, 1, 15 _
- Weekday(DateSerial(buf + 1, 1, 14), vbMonday))
Case vbCancel
Exit Sub
End Select

Set myRange = Range(DateColumn & ItemRow & "," & NameColumn & ItemRow)
For i = ItemRow + 1 To LastRow
buf = Range(DateColumn & i).Value
If buf >= TermStart And buf <= TermLast Then _
Set myRange = Union(myRange, Range(DateColumn & i & "," & NameColumn & i))
Next i
If Intersect(myRange, Range(DateColumn & ItemRow + 1 & ":" & NameColumn & LastRow)) Is Nothing Then
MsgBox "次の成人式に参加する資格のある方はリストの中には見当たりません。" _
& vbCrLf & "マクロを終了します。", vbInformation, "該当者無し"
Else

With Application
buf = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.ScreenUpdating = False
.Calculation = xlManual
End With

Set myBook = Workbooks.Add
myRange.Copy
With myBook.Sheets(1).Range(PasteCell)
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
End With

With Application
.CutCopyMode = False
.SheetsInNewWorkbook = buf
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End If

End Sub

お礼

いつもご教示有難うございます。

補足

有難うございますお世話になります。下記の生年月日で試しましたが、次の成人式に参加する資格のある方はリストの中には見当たりません。と出ました。
A 　B　　C　　　D　　　　E
No. 班 生年月日 　氏名 年齢
1 1 1995/11/4 ふふふ 21歳0ヶ月
2 2 1996/11/4 ひひひ 20歳0ヶ月
3 3 1997/11/4 へへへ 19歳0ヶ月
4 4 1998/11/4 ほほほ 18歳0ヶ月
どこが悪いのでしょうか？

回答No.2

ushi2015

こんにちは
C2:D2に項目名が有るとして、抽出日付は随時変更して貰えるなら、
Sub test()
　　Dim LastRow　As Long
　　Dim wBK　　　As Workbook
　　Dim r　　　　As Range

　　LastRow = Range("C" & Rows.Count).End(xlUp).Row
　　With Range("C2:D" & LastRow)
　　　　.AutoFilter Field:=1, _
　　　　　　Criteria1:=">1997/1/11", _
　　　　　　Operator:=xlAnd, _
　　　　　　Criteria2:="<1998/1/10"
　　　　Set r = .Parent.AutoFilter.Range
　　　　Set wBK = Workbooks.Add
　　　　r.Copy wBK.Worksheets(1).Range("A1")
　　　　If wBK.Worksheets(1).Range("A1") _
　　　　　　　　.CurrentRegion.Rows.Count = 1 Then
　　　　　　wBK.Saved = True
　　　　　　wBK.Close
　　　　End If
　　　　.Parent.AutoFilterMode = False
　　End With
End Sub

お礼

ushi2015 様のご教示を今勉強中です、有難うございます。結果、補足を入力するかもしれません、その時には宜しくお願いします。

回答No.1

maiko0333

来年成人式を迎えるのは１／１２から来年１／９までです。
この日付は毎年変わりますのでご注意。
地域によっては学年で成人式をやっているところもあります。
ちょっとプログラムにするのはややこしいかな。

お礼

有難うございました