エクセル VBAのオートフィルター実行時エラー
エクセル VBAのオートフィルター実行時エラーについて教えて下さい
VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」
が表示されるのですが、エラーの内容がわかりません。教えて下さい。
Sub 複数条件でのデータ抽出()
Const OrigSheetName = "データベース"
Const PasteSheetName = "検索＆抽出"
Const ItemRow = 2
Const FirstColumn = "A"
Const LastColumn = "CH"
Const UnnecessaryColumns = "W:CD"
Const SearchColumn1 = "CF"
Const SearchColumn2 = "I"
Const PasteCell = "A2"
Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _
LastRow As Long, Region As Variant, Period(1, 1) As Variant, _
temp As Variant, i As Long, c As Range
Period(0, 0) = "1905/1/1"
Period(1, 0) = "9999/12/31"
Period(0, 1) = "以降"
Period(1, 1) = "以前"
If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set OrigSheet = Sheets(OrigSheetName)
If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then
MsgBox "データの転記先のシートとして設定されている" _
& vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set PasteSheet = Sheets(PasteSheetName)
With OrigSheet
LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row
With .Range(LastColumn & Rows.Count).End(xlUp)
If LastRow > .Row Then LastRow = .Row
End With
If LastRow <= ItemRow Then GoTo label9
label1:
Region = Application.InputBox("参加または不参加を入力！", SearchColumn2 & _
"列に入力されている区分（Ａ組またはＢ組）の中で、抽出条件を入力して下さい", _
, Type:=6)
If Region = vbNullString Or Region = False Then
temp = MsgBox("区分が入力されていません。" & vbCrLf _
& "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:区分の入力をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "区分未入力")
If temp = vbNo Then
Exit Sub
Else
GoTo label1
End If
End If
For i = 0 To 1
label2:
Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _
"列に入力されている日付" _
& "で抽出する期間を指定して下さい。", _
Period(i, 0), Type:=2)
If Period(i, 0) = vbNullString Or Period(i, 0) = False Then
temp = MsgBox("日付が入力されていません。" & vbCrLf _
& "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:日付の入力をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "日付未入力")
If temp = vbNo Then
Exit Sub
Else
GoTo label2
End If
End If
If IsDate(Period(i, 0)) Then
If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _
Then GoTo label3
End If
temp = MsgBox("入力された値は日付として扱う事が出来ません。" _
& vbCrLf & "日付の入力をやり直して下さい。", _
vbOKOnly + vbExclamation, "入力値不適切")
GoTo label2
label3:
Period(i, 0) = DateValue(Period(i, 0))
Next i
End With
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
With OrigSheet
.Columns(UnnecessaryColumns).Hidden = True
With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow)
.AutoFilter Field:=1, Criteria1:=Region
.AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _
Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0)
End With
Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow)
i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count
End With
If i > 1 Then
With PasteSheet
.Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear
c.SpecialCells(xlCellTypeVisible).Copy
With .Range(PasteCell)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End If
With c.EntireColumn
.AutoFilter
.Hidden = False
End With
If i > 1 Then GoTo labelE
label9:
MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _
& "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i
labelE:
With Application
.CutCopyMode = False
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
１か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。
宜しくお願いします！
お礼
OMEGATさま 早速ありがとうございました。 解決できました。 しかし、なぜ既定のスクリプトホストがcscriptに設定されてしまったのか なぞです。