Macro to Extract Duplicate Items on Shet "Summary within sub-folders

[howard]

I have sheet a sheet called "summary" on workbooks like 'ACCNTS(P).xlsm" within the sub-folders of C:\Pull

I have tried to write code to extract the file Name on Col A where there are duplicate month and years in row1 on sheet "Summary" and extract the duplicate month and years in Col B seperated by a colon, but nothing is being extracted. There is one workbook that has a duplicate month and year

The following workbooks to be excluded when extracting the file name and duplicate month and years


"M_BR1 ACCNTS(P).xlsm" Or Filename Like "M_BR2 ACCNTS(P).xlsm" Or Filename Like "M_NCOR ACCNTS(P).xlsm")


Kinly amend my code accordingly

 Sub ExtractDuplicatesToNewWorkbook()
    Dim SourceFolderPath As String
    Dim DestWorkbook As Workbook
    Dim DestWorksheet As Worksheet
    Dim SubFolder As Object
    Dim Filename As String
    Dim LastColumn As Long
    Dim LastItem As String
    Dim monthYear As String
    Dim monthYearDict As Object
    
    ' Set the source folder path
    SourceFolderPath = "C:\pull"
    
    ' Create a new workbook for the extracted data
    Set DestWorkbook = Workbooks.Add
    Set DestWorksheet = DestWorkbook.Sheets(1)
    DestWorksheet.Name = "Duplicate Months"
    
    ' Initialize the row index for writing data in the destination sheet
    Dim DestRowIndex As Long
    DestRowIndex = 1
    
    ' Create a dictionary to store month and year combinations
    Set monthYearDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each direct subfolder in the source folder
    For Each SubFolder In CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderPath).SubFolders
        ' Reset the dictionary for each subfolder
        monthYearDict.RemoveAll
        
        ' Loop through each file in the subfolder
        Filename = Dir(SubFolder.Path & "\*ACCNTS(P).xlsm")
        Do While Filename <> ""
            ' Check if the workbook should be excluded
            If Not (Filename Like "M_BR1 ACCNTS(P).xlsm" Or Filename Like "M_BR2 ACCNTS(P).xlsm" Or Filename Like "M_NCOR ACCNTS(P).xlsm") Then
                ' Open the workbook without displaying alerts
                Dim SourceWorkbook As Workbook
                Set SourceWorkbook = Workbooks.Open(SubFolder.Path & "\" & Filename, False)
                
                ' Suppress messages and alerts from the workbook
                Application.DisplayAlerts = False
                Application.EnableEvents = False
                
                ' Get the last item in row 1 on the source sheet
                LastColumn = SourceWorkbook.Sheets("Summary").Cells(1, SourceWorkbook.Sheets("Summary").Columns.Count).End(xlToLeft).Column
                LastItem = SourceWorkbook.Sheets("Summary").Cells(1, LastColumn).Value
                
                ' Extract and check month and year
                monthYear = Format(SourceWorkbook.Sheets("Summary").Cells(2, LastColumn).Value, "mm-yyyy")
                If monthYearDict.Exists(monthYear) Then
                    ' Duplicate found, write file name and month-year to destination sheet
                    DestWorksheet.Cells(DestRowIndex, 1).Value = Filename
                    DestWorksheet.Cells(DestRowIndex, 2).Value = monthYear
                    DestRowIndex = DestRowIndex + 1
                Else
                    ' New month-year, add to dictionary
                    monthYearDict.Add monthYear, True
                End If
                
                ' Close the source workbook without saving changes and re-enable alerts
                SourceWorkbook.Close False
                Application.DisplayAlerts = True
                Application.EnableEvents = True
            End If
            
            ' Move to the next file
            Filename = Dir
        Loop
    Next SubFolder
    
    ' Auto-fit the column widths in the destination sheet
    DestWorksheet.Columns("A:B").AutoFit
    
    MsgBox "Duplicate Extraction completed!", vbInformation 
End Sub

 

[howard]

I have amended my code and it works perfectly

Sub ExtractDuplicatesToExistingWorkbook()
    Dim SourceFolderPath As String
    Dim DestWorksheet As Worksheet
    Dim SubFolder As Object
    Dim Filename As String
    Dim LastColumn As Long
    Dim LastItem As String
    Dim monthYear As String
    Dim monthYearDict As Object
    
    ' Set the source folder path
    SourceFolderPath = "C:\pull"
    
    ' Set the destination worksheet within the active workbook
    Set DestWorksheet = ThisWorkbook.Sheets("Duplicate Months")
    
    ' Clear existing data in columns A and B
    DestWorksheet.Range("A2:B" & DestWorksheet.Cells(DestWorksheet.Rows.Count, 1).End(xlUp).Row).ClearContents
    
    ' Initialize the row index for writing data in the destination sheet
    Dim DestRowIndex As Long
    DestRowIndex = 2
    
    ' Create a dictionary to store month and year combinations
    Set monthYearDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each direct subfolder in the source folder
    For Each SubFolder In CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderPath).SubFolders
        ' Reset the dictionary for each subfolder
        monthYearDict.RemoveAll
        
        ' Loop through each file in the subfolder
        Filename = Dir(SubFolder.Path & "\*ACCNTS(P).xlsm")
        Do While Filename <> ""
            ' Check if the workbook should be excluded
         If Not (Filename Like "M_BR1 ACCNTS(P).xlsm" Or Filename Like "M_BR2 ACCNTS(P).xlsm" Or Filename Like "M_NCOR ACCNTS(P).xlsm") Then
                ' Open the workbook without displaying alerts
                Dim SourceWorkbook As Workbook
                Set SourceWorkbook = Workbooks.Open(SubFolder.Path & "\" & Filename, False)
                
                ' Suppress messages and alerts from the workbook
                Application.DisplayAlerts = False
                Application.EnableEvents = False
                
                ' Get the last column number
                LastColumn = SourceWorkbook.Sheets("Summary").Cells(1, SourceWorkbook.Sheets("Summary").Columns.Count).End(xlToLeft).Column
                
                ' Loop through each month-year combination
                For col = 2 To LastColumn
                    ' Extract and check month and year
                    monthYear = SourceWorkbook.Sheets("Summary").Cells(1, col).Value
                    If monthYearDict.Exists(monthYear) Then
                        ' Duplicate found, write file name and month-year to destination sheet
                        DestWorksheet.Cells(DestRowIndex, 1).Value = Filename
                        DestWorksheet.Cells(DestRowIndex, 2).Value = monthYear
                        DestRowIndex = DestRowIndex + 1
                    Else
                        ' New month-year, add to dictionary
                        monthYearDict.Add monthYear, True
                    End If
                Next col
                
                ' Close the source workbook without saving changes and re-enable alerts
                SourceWorkbook.Close False
                Application.DisplayAlerts = True
                Application.EnableEvents = True
            End If
            
            ' Move to the next file
            Filename = Dir
        Loop
    Next SubFolder
    
    ' Auto-fit the column widths in the destination sheet
    DestWorksheet.Columns("A:B").AutoFit
    
    MsgBox "Duplicate Extraction completed!", vbInformation
End Sub