Home |
Search |
Today's Posts |
|
#1
|
|||
|
|||
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
__________________
Regards Gaurav |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Generate a filename from cell range? Anyone. | Excel Discussion (Misc queries) | |||
Macro to generate a file from another | Excel Worksheet Functions | |||
help required with using cells to generate a filename | Excel Programming | |||
Using TODAY() to generate a filename from where values are VLOOKUPed | Links and Linking in Excel | |||
Automatically generate a unique file name via macro... | Excel Programming |