Include source sheet name to an output sheet

Question

I'm trying to consolidate multiple sheets into one sheet and add a new column for the final "Combined" sheet. The new sheet should have a column named "Source" with the sheet name from where the rows behind it are copied.

Sub Final()
Path = " "
Filename = Dir(Path & "*.csv")

Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
  For Each Sheet In ActiveWorkbook.Sheets
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
Loop

Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")

For J = 2 To Sheets.Count
  Sheets(J).Activate
  Range("A1").Select
  Selection.CurrentRegion.Select
  Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
  Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

thanks in advance for your help guys :)

Answer 1

The code below will copy the sheet's name inside the For J = 2 To ThisWorkbook.Sheets.Count loop to column B (first empty row equivalent to the data exists in Column A).

There are no Select, Selection and ActiveWorkbook, instead there are fully qualified objects like Workbooks, Worksheets and Ranges.

Also, when using On Error Resume Next you should also try to see where the error is coming from, and how to handle it. In your case, it's coming when trying to rename the new created sheet with the name "Combined" , and there is already a worksheet in your workbook with this name. The result is the code skips this line, and the worksheet's names stays wth the default name given by Excel (which is "Sheet" and first available index number).

Code

Option Explicit

Sub Final()

Dim wb As Workbook
Dim Sheet As Worksheet
Dim Path As String, FileName As String
Dim J As Long

Path = " "
FileName = Dir(Path & "*.csv")

Do While FileName <> ""
    Set wb = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
    For Each Sheet In wb.Sheets
        Sheet.Copy after:=ThisWorkbook.Sheets(1)
    Next Sheet
    wb.Close
    Set wb = Nothing
    FileName = Dir()
Loop

On Error Resume Next
Set Sheet = Worksheets.Add(after:=Sheets(1))
Sheet.Name = "Combined"
If Err.Number <> 0 Then
    Sheet.Name = InputBox("Combined already exists in workbook, select a different name", "Select new created sheet's name")
End If
On Error GoTo 0

Sheets(2).range("A1").EntireRow.Copy Sheets(1).range("A1")

For J = 2 To ThisWorkbook.Sheets.Count
    With Sheets(J)
        .Range("A1").CurrentRegion.Offset(1, 0).Resize(.Range("A1").CurrentRegion.Rows.Count - 1, .Range("A1").CurrentRegion.Columns.Count).Copy _
        Destination:=Sheets(1).Range("A65536").End(xlUp)
        Sheets(1).Range("B" & Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row).Value = .Name '<-- copy the sheet's name to column B
    End With
Next J       

End Sub

Answer 2

This will create a new sheet or clean the existing one and add 2 columns :

• One for the source sheet
• One for the source file

Give a try :

Sub Test_Matt()
Dim BasePath As String
Dim FileName As String
Dim tB As Workbook
Dim wB As Workbook
Dim wS As Worksheet
Dim wSCopied As Worksheet
Dim LastRow As Double
Dim ColSrcShtCombi As Integer
Dim ColSrcWbCombi As Integer
Dim wSCombi As Worksheet
Dim NextRowCombi As Double
Dim J As Integer

Set tB = ThisWorkbook
On Error Resume Next
    Set wSCombi = tB.Sheets("Combined")
    If wSCombi Is Nothing Then
        Set wSCombi = tB.Sheets.Add
        wSCombi.Name = "Combined"
    Else
        wSCombi.Cells.Clear
    End If
On Error GoTo 0

With wSCombi
    '''I don't know which sheet that is your take your headers from,
    '''but here is where to define it:
    tB.Sheets(2).Range("A1").EntireRow.Copy Destination:=wSCombi.Range("A1")
    '''Add "Source"s columns
    ColSrcShtCombi = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
    .Cells(1, ColSrcShtCombi).Value = "Source Sheet"
    ColSrcWbCombi = ColSrcShtCombi + 1
    .Cells(1, ColSrcWbCombi).Value = "Source Workbook"
End With

'''Define here the folder you want to scan:
BasePath = "C:\Example\"
FileName = Dir(BasePath & "*.csv")

Do While FileName <> vbNullString
    Set wB = Workbooks.Open(FileName:=BasePath & FileName, ReadOnly:=True)
    For Each wS In wS.Sheets
        Set wSCopied = wS.Copy(After:=tB.Sheets(tB.Sheets.Count))
        '''Find next available row in Combined sheet
        NextRowCombi = wSCombi.Range("A" & wSCombi.Rows.Count).End(xlUp).Row + 1
        With wSCopied
            '''Find the last row of data in that sheet
            LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
            '''Copy the data in Combined sheet
            .Range("A2", .Cells(LastRow, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy _
                Destination:=wSCombi.Range("A" & NextRowCombi)
            '''Put sheet's name and workbook's name in source columns
            wSCombi.Range(wSCombi.Cells(NextRowCombi, ColSrcShtCombi), wSCombi.Cells(NextRowCombi + LastRow - 1, ColSrcShtCombi)).Value = wS.Name
            wSCombi.Range(wSCombi.Cells(NextRowCombi, ColSrcWbCombi), wSCombi.Cells(NextRowCombi + LastRow - 1, ColSrcWbCombi)).Value = wB.Name
        End With 'wSCopied
    Next wS
    wB.Close
    FileName = Dir()
Loop

End Sub