Add DateModified to Combine data from multiple workbooks into a single worksheet in a new workbook

WaHiGuy

New Member
Joined
Feb 14, 2021
Messages
1
Office Version
  1. 2013
Platform
  1. Windows
Hello, I'm an intermediate VBA User with very basic knowledge. I appreciate any help in what I hope is one or two lines of code.

I'm using this Code from Jerry Beaucaire, below, with some modifications... I'm not moving files to another folder;
My Goal is to pull specific cell data from certain sheets within each workbook and all is working well in the coding so far
My Request is to pull the File Save Date (DateLastModified) for each file (see Blue Text below) in the folder.

Private Sub CommandButton1_Click()

'Author: Jerry Beaucaire'
'Date: 9/15/2009 (2007 compatible) (updated 4/29/2011)
'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
Application.AskToUpdateLinks = False 'turn off Update Links question

Set wsMaster = ThisWorkbook.Sheets("Pipe") '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)
'========
MsgBox "Please select a folder with files to consolidate"
Do
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\2010\Test\"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
fPath = .SelectedItems(1) & "\"
Exit Do
Else
If MsgBox("No folder chose, do you wish to abort?", _
vbYesNo) = vbYes Then Exit Sub
End If
End With
Loop
'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
'========
'OR when you get to work

'fPath = "H:\_Completed Reviews\" 'remember final \ in this string

' On Error Resume Next
' 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
Workbooks(fName).Worksheets("Updates").Range("A1").Copy _
Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("A" & NR)
Workbooks(fName).Worksheets("Updates").Range("C13").Copy _
Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("B" & NR)
Workbooks(fName).Worksheets("Decn").Range("C8").Copy _
Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("C" & NR)
Workbooks(fName).Worksheets("Updates").Range("G6:J6").Copy _
Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("D" & NR)

NEED HELP ==> ALSO PULL THE FILE (fname) DATE MODIFIED property and PRINT to Column E of (Pipeline.xlsm).Worksheets("Pipe") <NEED HELP Here


'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
 

Some videos you may like

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
304
Office Version
  1. 365
Platform
  1. Windows
Check if the code below does the trick:
(Please use the code-wrapping function of the forum when you post a code because codes without it are very hard to see.)
VBA Code:
Private Sub CommandButton1_Click()

    'Author: Jerry Beaucaire'
    'Date: 9/15/2009 (2007 compatible) (updated 4/29/2011)
    '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
    Application.AskToUpdateLinks = False 'turn off Update Links question

    Set wsMaster = ThisWorkbook.Sheets("Pipe") '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)
        '========
        MsgBox "Please select a folder with files to consolidate"
        Do
            With Application.FileDialog(msoFileDialogFolderPicker)
                .InitialFileName = "C:\2010\Test\"
                .AllowMultiSelect = False
                .Show
                If .SelectedItems.Count > 0 Then
                    fPath = .SelectedItems(1) & "\"
                    Exit Do
                Else
                    If MsgBox("No folder chose, do you wish to abort?", vbYesNo) = vbYes Then Exit Sub
                End If
            End With
        Loop
        '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
        '========
        'OR when you get to work

        'fPath = "H:\_Completed Reviews\" 'remember final \ in this string

        'On Error Resume Next
        '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
                Workbooks(fName).Worksheets("Updates").Range("A1").Copy Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("A" & NR)
                Workbooks(fName).Worksheets("Updates").Range("C13").Copy Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("B" & NR)
                Workbooks(fName).Worksheets("Decn").Range("C8").Copy Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("C" & NR)
                Workbooks(fName).Worksheets("Updates").Range("G6:J6").Copy Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("D" & NR)

                'NEED HELP ==> ALSO PULL THE FILE (fname) DATE MODIFIED property and PRINT to Column E of (Pipeline.xlsm).Worksheets("Pipe") <NEED HELP Here
                Workbooks("Pipeline.xlsm").Worksheets("Pipe").Range("E" & NR) = Format(Workbooks(fName).BuiltinDocumentProperties("Last Save Time"), "short date")

                '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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,502
Messages
5,625,179
Members
416,076
Latest member
ralitsab

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