Combining Files with File Name

Bostockm

New Member
Joined
Nov 20, 2014
Messages
9
Hi,

I have built a VBA macro to combine multiple Excel files into one sheet, format the contents and then do some calculations.

However, it would be really useful to have the original file name against each row in the combined sheet. For example, I could see that rows 1-20 came from Sheet A, 21-40 Sheet B and 41-60 Sheet C etc.

Here is the code that I used to combine the worksheets. Does anybody know how I could modify this to add the original workbook name into Column A of the combined sheet?

Code:
Sub ReportRunner()

Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range


'initialize constants
MaxNumberFiles = 2001
HeaderRow = 6 'assume headers are always in row 1
LastOutRow = 1


'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Select Boards to Combine:"
    .ButtonName = ""
    .Filters.Clear
    .Show
End With


'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If


'set up the output workbook
Set OutBook = ActiveWorkbook
Set OutSheet = ActiveWorkbook.Sheets(2)


'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count


    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    Set DataSheet = DataBook.ActiveSheet


    'identify row/column boundaries
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column


    'if this is the first go-round, include the header
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header
    Else
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If


    'copy the data to the outbook
    DataRng.Copy OutRng


    'close the data book without saving
    DataBook.Close False


    'update the last outbook row
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row


Next FileIdx

Any help is very much appreciated.
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.

RickXL

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,328
Hi,

Try this:
Code:
Sub ReportRunner()

    Dim DataBook As Workbook, OutBook As Workbook
    Dim DataSheet As Worksheet, OutSheet As Worksheet
    Dim TargetFiles As FileDialog
    Dim MaxNumberFiles As Long, FileIdx As Long, _
        LastDataRow As Long, LastDataCol As Long, _
        HeaderRow As Long, LastOutRow As Long
    Dim DataRng As Range, OutRng As Range
    
    
    'initialize constants
    MaxNumberFiles = 2001
    HeaderRow = 6 'assume headers are always in row 1
    LastOutRow = 1
    
    
    'prompt user to select files
    Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
    With TargetFiles
        .AllowMultiSelect = True
        .Title = "Select Boards to Combine:"
        .ButtonName = ""
        .Filters.Clear
        .Show
    End With
    
    
    'error trap - don't allow user to pick more than 2000 files
    If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
        MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
        Exit Sub
    End If
    
    
    'set up the output workbook
    Set OutBook = ActiveWorkbook
    Set OutSheet = ActiveWorkbook.Sheets(2)
    
    
    'loop through all files
    For FileIdx = 1 To TargetFiles.SelectedItems.Count
    
    
        'open the file and assign the workbook/worksheet
        Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
        Set DataSheet = DataBook.ActiveSheet
       
       
        'identify row/column boundaries
        LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    
        'if this is the first go-round, include the header
        If FileIdx = 1 Then
            Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
            Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
        'if this is NOT the first go-round, then skip the header
        Else
            Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
            Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
        End If
    
    
        'copy the data to the outbook
        DataRng.Copy OutRng[B][COLOR=#ff0000].Offset(0, 1)[/COLOR][/B]
        [B][COLOR=#ff0000]OutRng.Resize(, 1) = DataBook.Name & " " & DataSheet.Name[/COLOR][/B]
    
        'close the data book without saving
        DataBook.Close False
    
    
        'update the last outbook row
        LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    
    Next FileIdx
End Sub
The Offset property moves the original output across one column.
The next line resizes OutRng to just one column but keeps the existing rows then writes the workbook name and sheet name into that range.
 

Bostockm

New Member
Joined
Nov 20, 2014
Messages
9
Hi,

Try this:
Code:
Sub ReportRunner()

    Dim DataBook As Workbook, OutBook As Workbook
    Dim DataSheet As Worksheet, OutSheet As Worksheet
    Dim TargetFiles As FileDialog
    Dim MaxNumberFiles As Long, FileIdx As Long, _
        LastDataRow As Long, LastDataCol As Long, _
        HeaderRow As Long, LastOutRow As Long
    Dim DataRng As Range, OutRng As Range
    
    
    'initialize constants
    MaxNumberFiles = 2001
    HeaderRow = 6 'assume headers are always in row 1
    LastOutRow = 1
    
    
    'prompt user to select files
    Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
    With TargetFiles
        .AllowMultiSelect = True
        .Title = "Select Boards to Combine:"
        .ButtonName = ""
        .Filters.Clear
        .Show
    End With
    
    
    'error trap - don't allow user to pick more than 2000 files
    If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
        MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
        Exit Sub
    End If
    
    
    'set up the output workbook
    Set OutBook = ActiveWorkbook
    Set OutSheet = ActiveWorkbook.Sheets(2)
    
    
    'loop through all files
    For FileIdx = 1 To TargetFiles.SelectedItems.Count
    
    
        'open the file and assign the workbook/worksheet
        Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
        Set DataSheet = DataBook.ActiveSheet
       
       
        'identify row/column boundaries
        LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    
        'if this is the first go-round, include the header
        If FileIdx = 1 Then
            Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
            Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
        'if this is NOT the first go-round, then skip the header
        Else
            Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
            Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
        End If
    
    
        'copy the data to the outbook
        DataRng.Copy OutRng[B][COLOR=#ff0000].Offset(0, 1)[/COLOR][/B]
        [B][COLOR=#ff0000]OutRng.Resize(, 1) = DataBook.Name & " " & DataSheet.Name[/COLOR][/B]
    
        'close the data book without saving
        DataBook.Close False
    
    
        'update the last outbook row
        LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    
    Next FileIdx
End Sub
The Offset property moves the original output across one column.
The next line resizes OutRng to just one column but keeps the existing rows then writes the workbook name and sheet name into that range.

Thanks, this worked perfectly!
 

Forum statistics

Threads
1,137,353
Messages
5,680,998
Members
419,948
Latest member
Sbakker1

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top