VBA年月日から５年以上のデータ新規ブックに出力

質問

お世話になります、A3日付...............L3合計とあります.
A4からLastRowまでの日付の中から５年以上経過したAからLまでのデータを新規ブックのsheet1に書き出したいのですがご存知の方ご教示ください、宜しくお願いします。

回答No.4

kagakusuki · ベストアンサー

発想を転換して、シートのコピーで移動先ブック名を「(新しいブック)」にした上で、不要な「5年よりも新しい日付の行」や「日付が入力されていない行」を削除してしまうというのは如何でしょうか？

Sub QNo9246888_VBA年月日から5年以上のデータ新規ブックに出力()

Const ItemRow As Long = 3 '項目名が入力されている行の行番号
Const SearchColumn As String = "A" '日付が入力されている列の列番号
Const myExpiredYear As Long = 5 'この数値に相当する年数が経過したデータのみを取り出す
Const NewSheetName As String = "Sheet1" '転記先のシート名

Dim c As Range, OriginalSheet As Worksheet, LastRow As Long _
, NewBooK As Workbook, myExpired As Date, DeleteRow As Range

Set OriginalSheet = ActiveSheet
myExpired = DateAdd("yyyy", -myExpiredYear, Date)

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

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

OriginalSheet.Copy
Set NewBooK = Workbooks(Workbooks.Count)
With NewBooK
With .Sheets(1)
.UsedRange.Value = .UsedRange.Value
.Name = NewSheetName
Set DeleteRow = .Cells(LastRow + 2, 1)
For Each c In .Range(SearchColumn & ItemRow + 1 & ":" _
& SearchColumn & .Range(SearchColumn & .Rows.Count).End(xlUp).row)
If c.Value > myExpired Or TypeName(c.Value) <> "Date" Then _
Set DeleteRow = Union(DeleteRow, c)
Next c
DeleteRow.EntireRow.Delete
.Cells(1, 1).Select
Application.Goto Reference:=.Cells(1, 1), Scroll:=True
End With
End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

構文、回避処理までご教示していただき有難うございます、又
先の御二方のご教示も素晴らしかったですがこの度はkagakusuki様のご教示構文が私には理解しやすかったので、組み込ませていただくことにしました、感謝いたします

回答No.3

mt2015

手抜きですがこんな感じでしょうか。
新規ブックのN1:N2に抽出条件を作成し、フィルタオプション（＝AdvancedFilter）でフィルタ結果を新規ブックに張り付けています。

Sub Sample()
　　nLastRow = Cells(Rows.Count, 1).End(xlUp).Row
　　With ThisWorkbook.ActiveSheet
　　　　Workbooks.Add
　　　　Range("N1") = .Range("A3")
　　　　Range("N2") = "<=" & DateAdd("yyyy", -5, Date)
　　　　.Range("A3:L" & nLastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("N1:N2"), CopyToRange:=Range("A1")
　　End With
End Sub

お礼

有難うございました。できました、感謝いたします。

回答No.2

SI299792

すみません。上記プログラムにバグ。差し替えです。
'
Option Explicit
'
Sub Macro1()
'
　　 Dim IY As Long
　　 Dim OldDate As Date
'
　　 Application.ScreenUpdating = False
　　 Workbooks.Add
　　 [A3:L3] = ThisWorkbook.ActiveSheet.[A3:L3].Value
　　 OldDate = DateAdd("yyyy", -5, Date)
'
　　 For IY = 4 To ThisWorkbook.ActiveSheet.[A3].End(xlDown).Row
　　　　 If ThisWorkbook.ActiveSheet.Cells(IY, "A") < OldDate Then
　　　　　　　　ThisWorkbook.ActiveSheet.Cells(iy, "A").Range("A1:L1").Copy Cells(iy, "A")
'　　　　　　　　 Cells(IY, "A").Range("A1:L1") = ThisWorkbook.ActiveSheet.Cells(IY, "A").Range("A1:L1").Value
　　　　 End If
　　 Next IY
End Sub

お礼

ご丁寧にありがとうございました。できました！感謝いたします

回答No.1

SI299792

途中に日付の空白はがないものとしました。
５年前の当日は、含めていません。
含める場合は、< を<=にして下さい。
'
Option Explicit
'
Sub Macro1()
'
　　Dim OldDate As Date
'
　　Workbooks.Add
　　[A3:L3] = ThisWorkbook.ActiveSheet.[A3:L3].Value
　　OldDate = DateAdd("yyyy", -5, Date)
'
　　For iy = 4 To ThisWorkbook.ActiveSheet.[A3].End(xlDown).Row
　　　　If ThisWorkbook.ActiveSheet.Cells(iy, "A") < OldDate Then
　　　　　　ThisWorkbook.ActiveSheet.Cells(iy, "A").Range("A1:L1").Copy Cells(iy, "A")
　　　　End If
　　Next iy
End Sub

セルの中に数式や書式があるかもしれないと思いコピーにしました。
そういうものがないときは、Ifの中をこのようにした方が実行速度は速いと思います。
　　　　　　 Cells(IY, "A").Range("A1:L1") = ThisWorkbook.ActiveSheet.Cells(IY, "A").Range("A1:L1").Value