| |
UserFormのListBoxの場合
UsetFormのコードモジュールに以下を記述
Option Explicit
Private Sub ListBox1_Click()
Extraction ListBox1.Value
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
With ListBox1
For i = 100 To 200 Step 10
.AddItem i
Next i
End With
End Sub
'標準モジュールに記述
Option Explicit
Public Sub Extraction(lngBase As Long)
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 rngResult
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows > 0 Then
.Offset(1).Resize(lngRows).ClearContents
End If
End With
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 lngBase - 30 <= vntData(i, 2) _
And vntData(i, 2) <= lngBase + 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:44 -
