Adding a column that says the file name data is orignally from

[dstar]

I wrote a vba script that combined a bunch of workbooks into one master workbook. I want to add a line of code that will basically say which file the data originally came from. Preferably in the last column.

So for example, if the first 20 rows of data came originally from the file "January" a column at the end will be added that says January for all 20 rows.

Thanks!

 

[Norie]

Should be straightforward, can you post your code?

 

[dstar]

All I have now is the data compilation coding. I have nothing about adding a new column at the end that will say the file the data came from:

Option Explicit

Sub Consolidate()
'Summary: Merge files in a specific folder into one master sheet (stacked)
' Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now

Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet report is built into

With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If

'Path and filename (edit this section to suit)
fPath = "C:\2011\Files" 'remember final \ in this string
fPathDone = fPath & "Imported" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired

'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file

'This is the section to customize, replace with your own action code as needed
LR = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With

ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub

 

[dstar]

Bump