Hi,

Am Mon, 25 Nov 2013 08:20:21 +0000 schrieb Gaura215:

I have been able to extract the relevant data from multiple files to my
master sheet using the following code mentioned in this thread. And they
are getting captured from coloumn B onwards which is exactly as per my
requirements. Where I am stuck now is that, I am unable to understand
the source file of the data from which it have been copied.
What I need now is that coloum A in each row reflects the full file name
from where the data has been copied. So, I will have the source in
coloum A from where Data in coloum B onwards have been copied from.

Select, Selection and Activate is not needed.
Try:

Sub CopyData()
Dim objFSO As Object
Dim objFolder As Object
Dim objDatei As Object
Dim objSubFolder As Object
Dim FERow As Range
Dim LRow As Long
Dim LCol As Integer

Const myPath = "C:\Users\g.khanna\Desktop\Recons\Spain\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(myPath)

On Error Resume Next

Application.DisplayAlerts = False

For Each objDatei In objFolder.Files
Workbooks.Open myPath & objDatei.Name
With ActiveWorkbook.Sheets("Open items")
.Unprotect "trunte"
.Range("A15000") = "NON"
LRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("A9:I" & LRow).Copy
End With
With ThisWorkbook.Sheets("Sheet1")
Set FERow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
FERow.PasteSpecial xlPasteValues
.Range(.Cells(FERow.Row, 1), .Cells(FERow.Row + LRow - 8, 1)) _
= ActiveWorkbook.FullName
End With
ActiveWorkbook.Close savechanges:=False
Next

For Each objSubFolder In objFolder.subfolders
For Each objDatei In objSubFolder.Files
Workbooks.Open myPath & objSubFolder.Name _
& "\" & objDatei.Name
With ActiveWorkbook.Sheets("Open items")
.Unprotect "trunte"
.Range("A15000") = "NON"
LRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("A9:I" & LRow).Copy
End With
With ThisWorkbook.Sheets("Sheet1")
Set FERow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
FERow.PasteSpecial xlPasteValues
.Range(.Cells(FERow.Row, 1), .Cells(FERow.Row + LRow - 8, 1)) _
= ActiveWorkbook.FullName
End With
ActiveWorkbook.Close savechanges:=False
Next
Next

Application.DisplayAlerts = True
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2