[Solved] Copy Data from files in Folder DateWise

[mfaisal.ce]

Dear,

I have certain files in a folder and i am collecting certain data from each file into a Master file. Every thing is working fine but data is not being copied DATEWISE. What i need is, script copy data from all files but Datewise not randomly.

Kindly guide,

Regards

 

[Lutfor Rahman Shimanto]

Dear,

I have certain files in a folder and i am collecting certain data from each file into a Master file. Every thing is working fine but data is not being copied DATEWISE. What i need is, script copy data from all files but Datewise not randomly.

Kindly guide,

Regards

Dear Mfaisal

Thanks for reaching out and posting your problem. After reading the thread, I understand you have specific files in a folder. You collect certain data from each file into a Master file. You need a procedure to copy data from all files. And you want not only to copy data but also to copy data from these files date-wise.

The issue you are addressing can be resolved with Excel VBA code. I am introducing you to a sub-procedure developed in Excel VBA.

Excel VBA Code:

Sub SelectFilesAndCopyToMasterSheetAdvanced()

    Dim folderPath As String
    Dim fileName As String
    Dim filePath As String
    Dim fileCreationDate As Date
    Dim fileArr() As Variant
    Dim fileCount As Long
    Dim masterSheet As Worksheet
    Dim lastRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Range("A1:B" & Rows.Count).Clear
    
    fileName = Dir(folderPath & "\*.*")
    Do While fileName <> ""
        If Not (GetAttr(folderPath & "\" & fileName) And vbDirectory) = vbDirectory _
            And (LCase(Right(fileName, 4)) = ".xls" Or LCase(Right(fileName, 5)) = ".xlsx") Then
            
            filePath = folderPath & "\" & fileName
            fileCreationDate = FileDateTime(filePath)
            
            ReDim Preserve fileArr(1 To 2, 1 To fileCount + 1)
            fileArr(1, fileCount + 1) = fileName
            fileArr(2, fileCount + 1) = fileCreationDate
            
            fileCount = fileCount + 1
        
        End If
        
        fileName = Dir
    Loop
    
    Dim i As Long, j As Long
    Dim tempName As Variant, tempDate As Variant
    
    For i = 1 To fileCount - 1
        For j = i + 1 To fileCount
            If fileArr(2, j) < fileArr(2, i) Then
                tempName = fileArr(1, i)
                tempDate = fileArr(2, i)
                
                fileArr(1, i) = fileArr(1, j)
                fileArr(2, i) = fileArr(2, j)
                
                fileArr(1, j) = tempName
                fileArr(2, j) = tempDate
            End If
        Next j
    Next i
    
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Test"
    
    Dim rowNum As Long
    rowNum = 1
    
    For i = 1 To fileCount
        Sheets("Test").Cells(rowNum, 1).Value = fileArr(1, i)
        Sheets("Test").Cells(rowNum, 2).Value = fileArr(2, i)
        rowNum = rowNum + 1
    Next i
    
    Sheets("Test").Columns.AutoFit
    
    Set masterSheet = ThisWorkbook.Sheets("Master Sheet")
    lastRow = masterSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    For i = 1 To fileCount
        If LCase(Right(fileArr(1, i), 4)) = ".xls" Or LCase(Right(fileArr(1, i), 5)) = ".xlsx" Then
            filePath = folderPath & "\" & fileArr(1, i)
            
            Set wb = Workbooks.Open(filePath)
            Set ws = wb.Sheets(1)
            
            ws.Range("A1:C4").Copy masterSheet.Cells(lastRow, 2)
            
            wb.Close SaveChanges:=False
            
            lastRow = lastRow + 4
        
        End If
    Next i
    
    masterSheet.Columns.AutoFit
    
End Sub

Folder:

​

Excel Files:

​

Calculation:

​

Output:

​

Things to Remember: Delete the Test sheet if it exists before running the mentioned code.

The VBA macro SelectFilesAndCopyToMasterSheetAdvanced will help you manage and analyze Excel files in a folder. Firstly, it asks you to choose a folder. Later, it will retrieve the file names and creation date/time of Excel files and sorts them by date. It creates a new Test sheet to show the file details. As you requested, the macro later copies a specific range (A1:C4) from each Excel file and pastes it into the Master Sheet for further analysis.

This idea will attain your goal. Feel free to contact us again with any other inquiries.

Regards
Lutfor Rahman Shimanto

 

[mfaisal.ce]

Dear Mfaisal

Thanks for reaching out and posting your problem. After reading the thread, I understand you have specific files in a folder. You collect certain data from each file into a Master file. You need a procedure to copy data from all files. And you want not only to copy data but also to copy data from these files date-wise.

The issue you are addressing can be resolved with Excel VBA code. I am introducing you to a sub-procedure developed in Excel VBA.

Excel VBA Code:

Sub SelectFilesAndCopyToMasterSheetAdvanced()

    Dim folderPath As String
    Dim fileName As String
    Dim filePath As String
    Dim fileCreationDate As Date
    Dim fileArr() As Variant
    Dim fileCount As Long
    Dim masterSheet As Worksheet
    Dim lastRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
   
    Range("A1:B" & Rows.Count).Clear
   
    fileName = Dir(folderPath & "\*.*")
    Do While fileName <> ""
        If Not (GetAttr(folderPath & "\" & fileName) And vbDirectory) = vbDirectory _
            And (LCase(Right(fileName, 4)) = ".xls" Or LCase(Right(fileName, 5)) = ".xlsx") Then
           
            filePath = folderPath & "\" & fileName
            fileCreationDate = FileDateTime(filePath)
           
            ReDim Preserve fileArr(1 To 2, 1 To fileCount + 1)
            fileArr(1, fileCount + 1) = fileName
            fileArr(2, fileCount + 1) = fileCreationDate
           
            fileCount = fileCount + 1
       
        End If
       
        fileName = Dir
    Loop
   
    Dim i As Long, j As Long
    Dim tempName As Variant, tempDate As Variant
   
    For i = 1 To fileCount - 1
        For j = i + 1 To fileCount
            If fileArr(2, j) < fileArr(2, i) Then
                tempName = fileArr(1, i)
                tempDate = fileArr(2, i)
               
                fileArr(1, i) = fileArr(1, j)
                fileArr(2, i) = fileArr(2, j)
               
                fileArr(1, j) = tempName
                fileArr(2, j) = tempDate
            End If
        Next j
    Next i
   
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Test"
   
    Dim rowNum As Long
    rowNum = 1
   
    For i = 1 To fileCount
        Sheets("Test").Cells(rowNum, 1).Value = fileArr(1, i)
        Sheets("Test").Cells(rowNum, 2).Value = fileArr(2, i)
        rowNum = rowNum + 1
    Next i
   
    Sheets("Test").Columns.AutoFit
   
    Set masterSheet = ThisWorkbook.Sheets("Master Sheet")
    lastRow = masterSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
   
    For i = 1 To fileCount
        If LCase(Right(fileArr(1, i), 4)) = ".xls" Or LCase(Right(fileArr(1, i), 5)) = ".xlsx" Then
            filePath = folderPath & "\" & fileArr(1, i)
           
            Set wb = Workbooks.Open(filePath)
            Set ws = wb.Sheets(1)
           
            ws.Range("A1:C4").Copy masterSheet.Cells(lastRow, 2)
           
            wb.Close SaveChanges:=False
           
            lastRow = lastRow + 4
       
        End If
    Next i
   
    masterSheet.Columns.AutoFit
   
End Sub

Folder:

View attachment 393​

Excel Files:

View attachment 394​

Calculation:

View attachment 395​

Output:

View attachment 396​

Things to Remember: Delete the Test sheet if it exists before running the mentioned code.

The VBA macro SelectFilesAndCopyToMasterSheetAdvanced will help you manage and analyze Excel files in a folder. Firstly, it asks you to choose a folder. Later, it will retrieve the file names and creation date/time of Excel files and sorts them by date. It creates a new Test sheet to show the file details. As you requested, the macro later copies a specific range (A1:C4) from each Excel file and pastes it into the Master Sheet for further analysis.

This idea will attain your goal. Feel free to contact us again with any other inquiries.

Regards
Lutfor Rahman Shimanto

Dear,

Many thanks for the help but what if the files are modified at same time and date?

Each file have Date inside filename "DCS READING_25May2023000202.xlsx"? isn't it possible to extract date from file name and copy data from the file and then delete the file.


Waiting for your kind response

Regards,

 

[Lutfor Rahman Shimanto]

Dear,

Many thanks for the help but what if the files are modified at same time and date?

Each file have Date inside filename "DCS READING_25May2023000202.xlsx"? isn't it possible to extract date from file name and copy data from the file and then delete the file.


Waiting for your kind response

Regards,

Dear Mfaisal

Thanks for your question about the previous code. Multiple files may have the same modified dates. In this case, the code copies according to the serial as it appears in the folder after sorting by modified dates.

However, you are requesting to implement a procedure that will extract dates from files. Later it will sort the dates and copy them accordingly.

The implementation you are asking for is quite possible. I have studied the issue and come up with an algorithm. There are some challenges we must keep in mind. Firstly, the folder must contain Excel files with the same naming convention. Next, the month name will be a short form like May, Apr, Sep etc. It should be 3 letters to be more specific.

Currently, I am doing the coding part to implement the Algorithm. I will share the code and explanation with you as soon as I am done. Stay with ExcelDemy Forum. Good luck.

Regards
Lutfor Rahman Shimanto

 

[mfaisal.ce]

Thanks dear a lot...

Waiting for your response,

Regards,

 

[Lutfor Rahman Shimanto]

Dear,

Many thanks for the help but what if the files are modified at same time and date?

Each file have Date inside filename "DCS READING_25May2023000202.xlsx"? isn't it possible to extract date from file name and copy data from the file and then delete the file.


Waiting for your kind response

Regards,

Dear Mfaisal

Thanks a ton for staying with us. As per request, I am introducing an Excel VBA sub-procedure called SelectFilesAndCopyToMasterSheetAdvanced. This time, the procedure calls a User-defined function named GetMonthNumber.

Excel VBA Code:

Function GetMonthNumber(monthAbbreviation As String) As Integer

    Select Case LCase(monthAbbreviation)
        Case "jan"
            GetMonthNumber = 1
        Case "feb"
            GetMonthNumber = 2
        Case "mar"
            GetMonthNumber = 3
        Case "apr"
            GetMonthNumber = 4
        Case "may"
            GetMonthNumber = 5
        Case "jun"
            GetMonthNumber = 6
        Case "jul"
            GetMonthNumber = 7
        Case "aug"
            GetMonthNumber = 8
        Case "sep"
            GetMonthNumber = 9
        Case "oct"
            GetMonthNumber = 10
        Case "nov"
            GetMonthNumber = 11
        Case "dec"
            GetMonthNumber = 12
        Case Else
            GetMonthNumber = 0
    End Select
   
End Function

Sub SelectFilesAndCopyToMasterSheetAdvanced()

    Dim folderPath As String
    Dim fileName As String
    Dim filePath As String
    Dim fileArr() As Variant
    Dim fileCount As Long
    Dim masterSheet As Worksheet
    Dim lastRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
   
    Range("A1:B" & Rows.Count).Clear
   
    fileName = Dir(folderPath & "\*.*")
    Do While fileName <> ""
        If Not (GetAttr(folderPath & "\" & fileName) And vbDirectory) = vbDirectory _
            And (LCase(Right(fileName, 4)) = ".xls" Or LCase(Right(fileName, 5)) = ".xlsx") Then
           
            Dim dateStr As String
            dateStr = Mid(fileName, InStrRev(fileName, "_") + 1, 9)
           
            Dim fileDate As Date
            Dim day As String
            Dim month As String
            Dim year As Integer
           
            day = Left(dateStr, 2)
            month = Mid(dateStr, 3, 3)
           
            Dim yearStr As String
            yearStr = Mid(dateStr, 6, 4)
           
            If IsNumeric(yearStr) Then
                year = CInt(yearStr)
            Else
                year = 1900
            End If
           
            fileDate = DateSerial(year, GetMonthNumber(month), CInt(day))
           
            ReDim Preserve fileArr(1 To 2, 1 To fileCount + 1)
            fileArr(1, fileCount + 1) = fileName
            fileArr(2, fileCount + 1) = fileDate
           
            fileCount = fileCount + 1
           
           
'            Debug.Print dateStr
'            Debug.Print day
'            Debug.Print month
'            Debug.Print GetMonthNumber(month)
'            Debug.Print yearStr
'            Debug.Print year
'            Debug.Print fileDate
'            Debug.Print "_________"
       
        End If
       
        fileName = Dir
    Loop
   
    Dim i As Long, j As Long
    Dim tempName As Variant, tempDate As Variant
   
    For i = 1 To fileCount - 1
        For j = i + 1 To fileCount
            If fileArr(2, j) < fileArr(2, i) Then
                tempName = fileArr(1, i)
                tempDate = fileArr(2, i)
               
                fileArr(1, i) = fileArr(1, j)
                fileArr(2, i) = fileArr(2, j)
               
                fileArr(1, j) = tempName
                fileArr(2, j) = tempDate
            End If
        Next j
    Next i
   
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Test"
   
    Dim rowNum As Long
    rowNum = 1
   
    For i = 1 To fileCount
        Sheets("Test").Cells(rowNum, 1).Value = fileArr(1, i)
        Sheets("Test").Cells(rowNum, 2).Value = fileArr(2, i)
        rowNum = rowNum + 1
    Next i
   
    Sheets("Test").Columns.AutoFit
   
    Set masterSheet = ThisWorkbook.Sheets("Master Sheet")
    lastRow = masterSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
   
    For i = 1 To fileCount
        If LCase(Right(fileArr(1, i), 4)) = ".xls" Or LCase(Right(fileArr(1, i), 5)) = ".xlsx" Then
            filePath = folderPath & "\" & fileArr(1, i)
           
            Set wb = Workbooks.Open(filePath)
            Set ws = wb.Sheets(1)
           
            ws.Range("A1:C4").Copy masterSheet.Cells(lastRow, 2)
           
            wb.Close SaveChanges:=False
           
            lastRow = lastRow + 4
       
        End If
    Next i
   
    masterSheet.Columns.AutoFit
   
End Sub

User-defined Function:
The GetMonthNumber function takes a month abbreviation as input and returns the corresponding month number as an integer. It uses a Select Case statement to map the input abbreviation to the corresponding month number.
Sub-procedure:
The SelectFilesAndCopyToMasterSheetAdvanced subroutine lets us select a folder and copy data from Excel files. It creates a new Test worksheet to display the sorted file names and dates. Then, it opens each Excel file, copies a specific range from the first sheet, and pastes it into the Master Sheet.

Folder:

​

Excel Files:

​

Calculation:

​

Output:

​

Things to Remember:

• The chosen folder must contain Excel files with the same naming convention.
• The month name will be in short form when being used in naming.
• Delete the Test sheet if it exists before running the given code.

This idea helps you reach your goal. I'm also attaching the Workbook used to investigate your problem to help you understand better. Don't hesitate to contact us again if you have any more questions.

Regards
Lutfor Rahman Shimanto

 

[mfaisal.ce]

Thanks a lot... It worked perfectly