| |
こんなかな？
Option Explicit
Public Sub Sample()
'基準値を設定
Const clngBase As Long = 150
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim lngRow As Long
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出し「氏名」のセル位置)
Set rngList = ActiveSheet.Cells(1, "A")
'出力する位置を設定(列見出し「氏名」のセル位置)
Set rngResult = ActiveSheet.Cells(1, "D")
'列見出しをCopy
rngList.Copy Destination:=rngResult
'出力行初期値
lngRow = 1
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(1).Resize(lngRows, 2).Value
End With
'画面更新を停止
Application.ScreenUpdating = False
'先頭行から最終行まで繰り返し
For i = 1 To lngRows
'(150-30)以上、(150+30)以下なら
If clngBase - 30 <= vntData(i, 2) _
And vntData(i, 2) <= clngBase + 30 Then
'氏名を転記
rngResult.Offset(lngRow).Value = vntData(i, 1)
'転記行を更新
lngRow = lngRow + 1
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 06/3/29(水) 20:12 -
