VBA Code to paste multiple cells from one worksheet into another with the filenames

Question

I am new on doing the VBA codes. So not familiar with coding as such. Just copied few code snippets. However, not getting the desired output.

What I have done need is looped through excel files in a folder and pasted the desired data from the worksheets into the master worksheet.

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "C:\Users\check"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("C:\Users\Super\Desktop\Master")
Set ws2 = y.Sheets("Conso P-L")
Set ws3 = y.Sheets("Conso Expenses")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    With wb.Sheets("Profit-Loss")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
    End With
    Application.CutCopyMode = False

    With wb.Sheets("Expenses")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws3.Range("A" & Rows.Count).End(xlUp)(2)
    End With
    Application.CutCopyMode = False
    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

However, the problem is I need to add a column in the master worksheets to get the filenames of the source data (excluding the .xls or .xlsx), I am not able to figure out where to tweak the code!!

Added a screenshot below for the desired output I require. the filename is required in Column A of both the worksheets of the master workbook.

Appreciate if anybody can help please..

Welcome to SO, unfortunately what you ask isn't how this site works. For more details see How to Ask — Luuklag
@luuklag : Added a screenshot below for the desired output I require. the filename is required in Column A of both the worksheets of the master workbook. Please help in adding the relevant code! — Jaisy B
@luuklag : Deleted the answer below and updated the query above with the screenshot. Thanxs for the tip buddy! — Jaisy B

Luuklag Luuklag · Accepted Answer · 2018-07-20T18:57:24

In your code to copy replace the A with a B for the paste range.

With wb.Sheets("Profit-Loss")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:M" & lRow).Copy ws2.Range("B" & Rows.Count).End(xlUp)(2)
End With

Now your data gets pasted from column B onwards.

To get the name of the file you copied from you can use myFile.name. You want to paste that on the same rows you just copied your data to, so lets make use of the things you calculated to determine what to copy (lRow), together with the last empty row in column A.

Dim lRowA as Long
Dim PasteRows as Long
lRowA = ws2.Range("A" & Rows.Count).End(xlUp)
PasteRows = lRowA + lRow -1 ' the -1 is to compensate for the fact that your copy area starts on row 2.

ws2.Range(ws2.Cells(lRowA,1),ws2.Cells(PasteRows,1)).value = myFile.name

You can use above code to fill column A with the filename. Place it directly after your end with (twice) and change the appropriate ws names (ws2/ws3) to match the code in your with statement.

VBA Code to paste multiple cells from one worksheet into another with the filenames

1 Answers