Macro to generate FileName of the source file
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
|