If it is found it will copy the cell in a,c,e,g of that row to the basebook
Sub TestFile1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim a As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
rnum = 0
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
With mybook.Worksheets(1)
For r = .UsedRange.Rows.Count To 1 Step -1
If Trim(.Cells(r, "A").Value) = "ron" Then
rnum = rnum + 1
.Cells(r, 1).Range ("A1,C1,E1,G1").Copy _
Destination:=basebook.Worksheets (1).Cells(rnum, 1)
End If
Next
End With
mybook.Close False
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
--
Regards Ron de Bruin
(Win XP Pro SP-1 XL2002 SP-2)
"Peter" <
[email protected]> wrote in