| |
▼さくらんぼ さん：
こんにちは。
Sub フォルダ内検索()
Dim FSO As Object
Dim FolPath As String
Dim Fol As Object
Dim Fil As Object
Dim KWord As Variant
FolPath = "C:\データ\"
KWord = Application.InputBox("検索名を入力して下さい。")
If KWord = "" Or KWord = False Then Exit Sub
'--------------------------------------------------------------
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'--------------------------------------------------------------
ActiveSheet.Range(Rows(2), Rows(2).End(xlDown)).ClearContents
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fol = FSO.GetFolder(FolPath)
For Each Fil In Fol.Files
If FSO.GetExtensionName(Fil.Name) = "xls" Then
Call データ検索(KWord, FolPath & Fil.Name)
End If
Next
Set Fil = Nothing
Set Fol = Nothing
Set FSO = Nothing
'--------------------------------------------------------------
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'--------------------------------------------------------------
End Sub
Function データ検索(strName As Variant, FName As String)
Dim motoSheet As Worksheet
Dim Sht As Worksheet
Dim y As Long
Dim x As Long
Set motoSheet = ActiveSheet
Workbooks.Open (FName)
For Each Sht In ActiveWorkbook.Sheets
For y = 2 To Range("C65535").End(xlUp).Row
For x = 12 To 33 Step 3
If Sht.Cells(y, x).Value = strName Then
Sht.Rows(y).Copy
motoSheet.Paste motoSheet.Rows _
(motoSheet.Range("C65535").End(xlUp).Row + 1)
Exit For
End If
Next
Next
Next
ActiveWorkbook.Close (False)
Set motoSheet = Nothing
End Function
FileSystemObject を使用した以外は難しい命令は使っていないつもりです。
検索文字（作業者のみしか対応させていません）を入れると
変数「FolPath」に指定されたフォルダ内の全エクセルファイルを検索し、
見つかった場合はその行をコピーして元のシートに貼り付けるコードです。
|
|
小僧
- 05/7/8(金) 11:28 -
