<p>Option Explicit</p> <p> '******************************************************************************<br> '内容:検索条件を指定し、結果を出力する<br> '******************************************************************************</p> <p>Sub subFilter()</p> <p>Dim BaseDir As String<br> Dim InpFile As String<br> Dim OutFile As String</p> <p>Dim InpWkb As Workbook<br> Dim OutWkb As Workbook</p> <p>Dim rngInp As Range<br> Dim rngJouken As Range<br> Dim rngOut As Range</p> <p><br> 'カレントパス取得<br> BaseDir = ThisWorkbook.Path</p> <p>InpFile = BaseDir & "\" & "台帳.xls"</p> <p>OutFile = BaseDir & "\" & "フィルタテスト.xls"</p> <p>Set rngJouken = ThisWorkbook.Sheets("work").Range("検索条件")<br> Set rngOut = ThisWorkbook.Sheets("main").Range("C12")</p> <p><br> Set InpWkb = Workbooks.Open(InpFile)</p> <p>Set rngInp = InpWkb.Sheets("台帳").Cells(1, 1).CurrentRegion</p> <p>rngInp.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngJouken, CopyToRange:=rngOut, Unique:=False</p> <p>InpWkb.Close SaveChanges:=False</p> <p>Set InpWkb = Nothing</p> <p><br> End Sub</p> <br>