| |
帰って難しく成ったかな？
リスト
Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
01 氏名 機関 科目
02 ="=加藤" * *
・
・
09 氏名 日付 機関 科目 症状 指示 備考
10 加藤 2/3 Ａ あ アア 特になし ○
11 佐藤 2/3 Ａ あ イイ aaa ○
12 加藤 2/4 Ａ あ ウウ aaa △
13 加藤 3/2 Ｂ い エエ aaa △
Sheet1
Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
05 氏名 日付 機関 科目 症状 指示 備考
06 加藤 2/3 Ａ あ アア 特になし ○
07 加藤 2/4 Ａ あ ウウ aaa △
08 加藤 3/2 Ｂ い エエ aaa △
Option Explicit
Public Sub Sample()
'◆リストのデータ列数（B列〜F列）
Const clngColumns As Long = 7
Dim i As Long
Dim lngRows As Long
Dim rngList As Range '抽出元
Dim rngExtract As Range '抽出範囲
Dim rngCriteria As Range '条件範囲
Dim strProm As String
'◆Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("リスト").Cells(9, "B")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count _
- .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'◆抽出範囲を指定
Set rngExtract = Worksheets("Sheet1") _
.Cells(5, "B").Resize(, clngColumns)
'◆条件範囲を指定(「氏名」、「機関」、「科目」の3列)
Set rngCriteria = rngList.Parent.Cells(1, "B").Resize(2, 3)
'画面更新を停止
' Application.ScreenUpdating = False
'AdvancedFilterを実行
DoFilter rngList.Resize(lngRows + 1, clngColumns), _
rngCriteria, rngExtract
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngExtract = Nothing
Set rngCriteria = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DoFilter(rngScope As Range, _
rngCriteria As Range, _
rngCopyTo As Range, _
Optional blnUnique As Boolean)
' AdvancedFilterを実行
rngScope.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngCopyTo, _
Unique:=blnUnique
End Sub
|
|
Hirofumi
- 08/3/2(日) 19:10 -
