| |
前の物と基本的には、同じ物です
違いは、前回の物は、範囲外の日付を消して居たものを
消さない様にした事と、速度を上げる為、結果を配列で一遍に出力して居る事です
尚、書き忘れた事ですが、日付はシリアル値で入って居る事が必須です
Option Explicit
Public Sub Sample2()
'データの列数
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
'開始年月日入力
If Not GetDate(vntStart, "開始年月日入力", _
DateSerial(Year(Date), Month(Date), 1)) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'開始年月日入力
If Not GetDate(vntFInish, "終了年月日入力", _
DateSerial(Year(vntStart), Month(vntStart) + 1, 0)) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'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
'データを配列に取得(列見出しを含め)
lngRows = lngRows + 1
vntData = .Resize(lngRows, clngColumns).Value
End With
'画面更新を停止
Application.ScreenUpdating = False
'新規Bookを追加
Set wkbResult = Workbooks.Add
'結果を書き込むセル位置を設定
Set rngResult = wkbResult.Worksheets(1).Cells(1, "A")
'出力行位置の初期値設定
lngRow = 2
'データ行数全てに就いて繰り返し
For i = 2 To lngRows
'出力フラグをFalseに
blnOutPut = False
'データの比較
For j = 2 To clngColumns
'データが日付範囲に有る場合
If vntStart <= vntData(i, j) _
And vntData(i, j) <= vntFInish Then
'出力フラグをTrueに
blnOutPut = True
'比較行データを書き込み行に転記
vntData(lngRow, j) = vntData(i, j)
End If
Next j
'出力フラグがTrueなら（出力指定なら）
If blnOutPut Then
'名前データを転記
vntData(lngRow, 1) = vntData(i, 1)
'出力行位置を更新
lngRow = lngRow + 1
End If
Next i
'出力基準位置に就いて
With rngResult
'セルの書式設定
.Offset(1, 1).Resize(lngRow - 2, clngColumns - 1).NumberFormat = "m/d"
'データを出力
.Resize(lngRow - 1, clngColumns).Value = vntData
End With
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(日) 15:05 -
