Macro to generate FileName of the source file
 

Hello All

This is really urgent and appreciate all help in this regards.

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.

Hope I am able to explain it.

Following is the code I am currently using. Please please please help me!!

Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim SubF As Scripting.Folder

Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder("C:\Users\g.khanna\Desktop\Recons\Sp ain\")
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub

Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.file
Dim SubF As Scripting.Folder
Dim WB As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each F In FF.Files
Set WB = Workbooks.Open(F.Path)
' select data from open workbook
Sheets("Open items").Select
ActiveSheet.Unprotect Password:="trunte"
Range("A15000").Select
ActiveCell.FormulaR1C1 = "NON"
Range("A9:I9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("ADC Final.xlsm").Activate
Range("B2").Select
'find the next empty row
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
WB.Close SaveChanges:=False
Debug.Print F.Name
Next F

For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub

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