| |
私は、やはり望むのがどの様な結果なのか今一解りませんので
「期間内のデータを別のシートに抽出する」と解釈して以下の様にして見ました
ピントがずれて居たらゴメンナサイ
尚、オートフィルタは使用していません
Option Explicit
Public Sub Sample()
'データの列数
Const clngColumns As Long = 5
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngRow As Long
Dim rngList As Range
Dim vntData As Variant
Dim wkbResult As Workbook
Dim rngResult As Range
Dim vntStart As Variant
Dim vntFInish As Variant
Dim blnOutPut As Boolean
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'開始年月日入力
If Not GetDate(vntStart, "開始年月日入力", _
DateSerial(Year(Date), Month(Date), 1)) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'開始年月日入力
If Not GetDate(vntFInish, "終了年月日入力", _
DateSerial(Year(Date), Month(Date) + 1, 0)) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
' Application.ScreenUpdating = False
'新規Bookを追加
Set wkbResult = Workbooks.Add
'結果を書き込むセル位置を設定
Set rngResult = wkbResult.Worksheets(1).Cells(1, "A")
'結果用シートに列見出しを出力
rngResult.Resize(, clngColumns).Value _
= rngList.Resize(, clngColumns).Value
'出力行位置の初期値設定
lngRow = 1
'データ行数全てに就いて繰り返し
For i = 1 To lngRows
'データを配列に取得
vntData = rngList.Offset(i).Resize(lngRows, clngColumns).Value
'出力フラグをFalseに
blnOutPut = False
'データの比較
For j = 2 To clngColumns
'データが日付範囲に無い場合
If vntData(1, j) < vntStart Or vntFInish < vntData(1, j) Then
'配列位置をクリア
vntData(1, j) = Empty
Else
'出力フラグをTrueに
blnOutPut = True
End If
Next j
'出力フラグがTrueなら（出力指定なら）
If blnOutPut Then
'出力基準位置に就いて
With rngResult
'セルの書式設定
.Offset(lngRow, 2).Resize(, clngColumns - 1).NumberFormat = "m/d"
'データを出力
.Offset(lngRow).Resize(, clngColumns).Value = vntData
End With
'出力行位置を更新
lngRow = lngRow + 1
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
' Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set wkbResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetDate(vntDate As Variant, _
strTitle As String, _
vntDefault As Variant) As Boolean
' 年月日入力
Dim strPrompt As String
strPrompt = "月日を" & Format(vntDefault, "yyyy/m/d") & "の形で入力して下さい"
Do
vntDate = InputBox(strPrompt, strTitle, Format(vntDefault, "yyyy/m/d"))
If IsDate(vntDate) Then
vntDate = DateValue(vntDate)
GetDate = True
Exit Do
Else
If vntDate = "" Then
Exit Do
Else
Beep
strPrompt = strPrompt & "！"
End If
End If
Loop
End Function
|
|
Hirofumi
- 05/10/16(日) 0:30 -
